unt_cad_pro_tool.pas

煤矿行业采掘接替计划自动生成系统

             end
  else begin
         b:=(p2[1]-p1[1])/(p2[0]-p1[0]);
         k:=-1/b;
         thep[0]:=(p1[1]-p[1]+k*p[0]-b*p1[0])/(k-b);
         thep[1]:=(k*p1[1]-b*p[1]+b*k*p[0]-b*k*p1[0])/(k-b);
         thep[2]:=p1[2];
         if PInP1P2(thep,p1,p2)=0  //如果thep不在p1,p2的连线上
         then begin
               dis1:=Distance(p,p1);dis2:=Distance(p,p2);
               dis:=dis1;
               if (dis-dis2)>1e-3 then dis:=dis2;
              end
         else dis:=Distance(p,thep);
       end;
  result:=dis;
end;

function PInP1P2(p,p1,p2:TPoint1):Integer;
var alfa,bata:double;
begin
 //p不在p1,p2连线上
 result:=0;
 alfa:=p[0]-p1[0];bata:=p[1]-p1[1];
//如果p,p1重合
 if (abs(alfa)<1e-3)and(abs(bata)<1e-3) then
 begin
  result:=1;
  exit;
 end;
 alfa:=p[0]-p2[0];bata:=p[1]-p2[1];
 //如果p,p2重合
 if (abs(alfa)<1e-3)and(abs(bata)<1e-3) then
 begin
  result:=1;
  exit;
 end;
 alfa:=Direct(p,p1);bata:=Direct(p,p2);
 //如果p位于p1,p2连线上
 if abs(abs(alfa-bata)-pi)<1e-3 then result:=2;
end;

function PInListP(Pcou:integer;Inp:TPoint1;ListP:TPoints):boolean;
var Ang,Ang1,SumAng:double;
    i:integer;
begin
 result:=false;
 SumAng:=0;
 for i:=0 to Pcou-1 do
  begin
   Ang:=Direct(Inp,ListP[i mod Pcou]);
   Ang1:=Direct(InP,ListP[(i+1) mod Pcou]);
   Ang:=Ang1-Ang;
   if (Ang-pi)>1e-3 then Ang:=Ang-2*pi;
   if (Ang+pi)<-1e-3 then Ang:=Ang+2*pi;
   SumAng:=SumAng+Ang;
  end;
 if Abs(Abs(SumAng)-2*pi)<1e-3 then result:=true; 
end;

function P1EqualP2(P1,P2:TPoint1):boolean;
var Isequ:boolean;
begin
 Isequ:=true;
 if abs(p1[0]-P2[0])>1e-3 then Isequ:=false;
 if abs(p1[1]-P2[1])>1e-3 then Isequ:=false;
 if abs(p1[2]-P2[2])>1e-3 then Isequ:=false;
 result:=Isequ;
end;

procedure ExPoint(var StartP,EndP:TPoint1);
var p:TPoint1;
begin
 p:=StartP;
 StartP:=EndP;
 EndP:=p;
end;

procedure ExString(var SStr,EStr:string);
var str:string;
begin
 str:=SStr;
 SStr:=EStr;
 EStr:=str;
end;

procedure Exinteger(var Si,Ei:integer);
var i:integer;
begin
 i:=Si;
 Si:=Ei;
 Ei:=i;
end;

procedure ExDouble(var Sd,Ed:double);
var d:double;
begin
 d:=Sd;
 Sd:=Ed;
 Ed:=d;
end;

function DelSubStr(MonStr,SubStr:string):String;
var i,len:integer;
begin
  result:='';
  i:=pos(SubStr,MonStr);
  if i=0 then exit;
  len:=length(SubStr);
  delete(MonStr,i,len);
  result:=MonStr;
end;

function GetStr(MonStr:string;SubStrB,SubStrE:string):string;
var i,j,len:integer;
begin
 result:=MonStr;
 i:=pos(SubStrB,MonStr);
 j:=pos(SubStrE,MonStr);
 if (i=0)or(j=0) then exit;
 len:=j-i-1;
 result:=copy(MonStr,i+1,len);
end;

//计算某年某月的天数
function get_Year_days(y,m:integer):integer;
var i,j:integer;
begin
 i:=0;
 if (y mod 4)=0
 then begin
       if (y mod 100)=0
       then begin
             if (y mod 400)=0
             then i:=1
             else i:=0;
            end
       else i:=1
      end
 else i:=0; //平年
 case m of
  1,3,5,7,8,10,12:j:=31;
  2:begin
     if i=1
     then j:=29
     else j:=28
    end;
  4,6,9,11:j:=30;
 end;
 result:=j;
end;

  {component tool}
function GetId(ADOTDB:TDataSet;fieldstr:string):integer;
begin
  if ADOTDB.RecordCount=0
  then result:=0
  else begin
        ADOTDB.last;
        result:=ADOTDB.FieldByName(fieldstr).AsInteger;
       end;
end;

function EditIsNull(Edt:Tedit):boolean;
begin
 result:=false;
 if trim(edt.Text)=''
  then result:=true;
end;

function DBEditIsNull(DBEdt:TDBedit):boolean;
begin
 result:=false;
 if trim(DBEdt.Text)=''
  then result:=true;
end;

function ComboBoxIsNull(CBox:TComboBox):boolean;
begin
 result:=false;
 if trim(CBox.Text)=''
  then result:=true;
end;

function DBLookUpComboBoxIsNull(DBCBox:TDBLookupComboBox):boolean;
begin
 result:=false;
 if trim(DBCBox.Text)=''
  then result:=true;
end;

function DBComboBoxIsNull(DBCBox:TDBComboBox):boolean;
begin
 result:=false;
 if trim(DBCBox.Text)=''
  then result:=true;
end;

//System Tool
function CDMDDir(filestr:string):string;
begin
 try
  MkDir(filestr);
 except
  on EInoutError do ChDir(filestr);
 end;
 result:=filestr+'\'
end;

procedure ListDataS(DBLkUpCbx:TDBLookupComboBox;Ds:TDataSource;LField,KField:string);
begin
  DBLkUpCbx.ListSource:=Ds;
  DBLkUpCbx.ListField:=LField;
  DBLkUpCbx.KeyField:=KField;
end;

procedure ListDataS(DBLkUpLbx:TDBLookupListBox;Ds:TDataSource;LField,KField:string);
begin
  DBLkUpLbx.ListSource:=Ds;
  DBLkUpLbx.ListField:=LField;
  DBLkUpLbx.KeyField:=KField;
end;

function BlobContentToString(fileName:string):string;
begin
 with TFileStream.Create(fileName,fmOpenRead) do
 try
  setlength(result,size);
  read(Pointer(result)^,size);
 finally
  free;
 end;
end;

function StringToBlobContent(Tbl:TAdoTable;BlobF,Ext:string;OleCon:TOleContainer):string;
var SFilename:string;
    BS:TAdoBlobStream;
begin
 if (Tbl.IsEmpty)or(Tbl.FieldByName(Ext).AsString='') then exit;
 BS:=TAdoBlobStream.Create(TBlobField(Tbl.FieldByName(BlobF)),bmread);
 try
  SFilename:=Extractfilepath(Application.ExeName)+'TmpBlob';
  SFilename:=SFilename+'.'+Tbl.fieldbyname(Ext).AsString;
  BS.SaveToFile(SFilename);
  OleCon.CreateObjectFromFile(SFilename,false);
 finally
  BS.Free;
 end;
 result:=SFilename;
end;

function Confirm(Tbl:TDataSet):boolean;
begin
  result:=true;
  if MessageDlg('确认修改吗?',mtConfirmation,[mbYes, mbNo],0)=mrNo
   then begin
         result:=false;
         exit;
        end;
  with Tbl do
  begin
   if recordcount=0
    then begin
          showmessage('数据表为空，请首先添加纪录！');
          cancel;
          result:=false;
          exit;
         end;
   edit;
   post;
  end;
end;

function DelRec(Tbl:TDataSet):boolean;
var Bk:Tbookmark;
begin
  result:=false;
  with Tbl do
   if (MessageDlg('确定删除该记录吗?',mtConfirmation, [mbYes, mbNo], 0) = mrYes)
      and(IsEmpty=false)
   then begin
         if recordcount=0 then cancel;
         if RecordCount=1
          then begin
                delete;close;open;
               end;
          if recordcount>1
           then begin
                 //showmessage(inttostr(recordcount));
                 //if RecNo=0
                 if RecNo=1
                  then begin
                        next;
                        Bk:=getbookmark;
                        prior;
                       end
                  else begin
                        prior;
                        Bk:=getbookmark;
                        next;
                       end;
                 Delete;
                 close;open;// frm_data.connectdb;
                 if recordcount>1 then  GotoBookmark(Bk);
                 FreeBookmark(Bk);
                end;
         result:=true;
        end;
end;

//----------------平均值和方差-------------------------
function Average(SCou:integer;Sam:Tlistvalue):double;
var sum:double;
    i:integer;
begin
 result:=0;
 if SCou>0
  then begin
        sum:=0;
        for i:=0 to SCou-1 do sum:=sum+Sam[i];
        result:=sum/SCou;
       end;
end;

function Sigma(SCou:integer;Sam:Tlistvalue):double;
var Avg,Sum:double;
    i:integer;
begin
  result:=0;
  if SCou>0
   then begin
         Sum:=0;
         Avg:=Average(SCou,Sam);
         for i:=0 to SCou-1 do Sum:=Sum+Sqr(Sam[i]-Avg);
         result:=sqrt(Sum/(SCou-1));
        end;
end;

//-----------------拉格朗日插值----------------------------
function the_para(PId,PCou:integer;TPs:TPoints):double;
var j:integer;
begin  //TPs[PId,2]:=result;
 result:=TPs[PId,1];
 for j:=0 to PCou-1
  do if j<>PId then result:=result/(TPs[PId,0]-TPs[j,0]);
end;

function the_re(Px:double;PCou:integer;TPs:TPoints):double;
var i,j:integer;
    sum:double;
begin
 Sum:=0;
 for i:=0 to PCou-1 do
  begin
   for j:=0 to PCou-1
    do if j<>i then TPs[i,2]:=TPs[i,2]*(Px-TPs[j,0]);
   Sum:=Sum+TPs[i,2];
  end;
 result:=Sum;
end;

{ TExcel }

function TExcel.Link_Excel: boolean;
begin
 result:=false;
 try
    ExcelApp:=getactiveoleobject('Excel.Application');
 except
    on eolesyserror do
        try
          //Frm_CADPro:= TFrm_CADPro.Create(Application);
          //with Frm_CADPro do
           //begin
            //setvisible(false,false,true);
            //Show;
            //Update;
            ExcelApp:=CreateOleObject('Excel.Application');
            //Hide;
            //Free;
           //end;
        except
           showmessage('链接Excel出错，请确认Excel是否正确安装!!');
           result:=true;
           exit;
        end;
 end;
 Excelworkbooks:=ExcelApp.workbooks;
 Excelworkbooks.close;
 ExcelApp.Visible := true;
 //Excelworkbooks.;
 //Excelworkbook:=ExcelApp.activeworkbook;
end;

procedure TExcel.Add_XslWorkBook(BookStr,SheetStr: string);
var Id:integer;
begin
 Excelworkbook:=Excelworkbooks.add;
 ExcelworkSheets:=ExcelApp.WorkSheets;
 for Id:=1 to ExcelworkSheets.count-1 do
 begin
  ExcelworkSheets[Id].delete;
  ExcelApp.DisplayAlerts:=false;
 end;
 Excelworkbook.name:=BookStr;
 ExcelworkSheet:=ExcelworkSheets[1];
 ExcelworkSheet.name:=SheetStr;
end;                   

procedure TExcel.Add_XslWorkSheet(SheetStr: string);
begin
 ExcelworkSheet:=ExcelworkSheets.add;
 ExcelworkSheet.name:=SheetStr;
end;

procedure TExcel.Add_Field(i, j: integer; CellStr: string);
begin
 ExcelworkSheet.Cells[i,j].value:=CellStr;
end;

procedure TExcel.Open_XslWorkBook(BookStr: string);
begin
 Excelworkbooks.Open(BookStr);
 Excelworkbook:=ExcelApp.ActiveWorkbook;
 ExcelworkSheets:=ExcelApp.WorkSheets;
 ExcelworkSheet:=ExcelApp.ActiveSheet;
end;

end.