unt_cad_pro_tool.pas

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

{**********************************************}
{本单元主要包含AutoCAD、Project的数据导入和导出}
{过程以及一些通用的计算工具供图形数据读取和处理}
{生产过程模拟和动态演示用                      }
{**********************************************}

unit Unt_CAD_Pro_Tool; //Delphi调用AutoCAD的工具

interface
 uses comobj,Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls,variants,DBCtrls,ADODB,DB,OleCtnrs;

type
  Tlistvalue=array of double;
  TStrs=array of string;
  Tintegers=array of integer;

  TPoint1=array[0..2]of double;
  TPoints=array of TPoint1;
  TListPoints=array of TPoints;

  DListValue=array of array of double;

  TIdSide=record
        PCou:integer;//一边点的个数
        Ps:TPoints; //具体点坐标  array of TPoint1
    end;
  TIdSides=record
        LsPsCou:integer;//边的个数
        LsPs:array of TIdSide; //具体边情况
    end;

  //AutoCAD对象模型
  TAcad=class(tobject)
    function Link_CAD:Boolean;
    procedure CloseAll;
    procedure Add_Doc(DocName:string);
    procedure Open_doc(DocName:string);
    procedure SetTxtStyle(Style:string);
    procedure Cad_WinState(StateID:integer);//1,2,3
    procedure ZoomAll;
    function xyz_olevar(p:TPoint1):olevariant;
    procedure RS_LineType(var LineTypes:TStrings);virtual;abstract;
    procedure RS_TextStyle(var TextSty,Fontf:TStrings);virtual;abstract;
    procedure RS_Layer(var layers:TStrings);virtual;abstract;
    procedure RS_line(var Sp,Ep:TPoint1;var col:integer;var layer,linetype,handle:string);virtual;abstract;
    procedure RS_Pline(var PCount:integer;var ListP:TPoints;var widList,BugList:TListvalue;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);virtual;abstract;
    procedure RS_3DPoly(var PCount:integer;var ListP:TPoints;var widList,BugList:TListvalue;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);virtual;abstract;
    procedure RS_Spline(var PCount:integer;var ListP:TPoints;var S_Tan,E_Tan:TPoint1;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);virtual;abstract;
    procedure RS_Arc(var CenP:TPoint1;var col:integer;var Radius,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);virtual;abstract;
    procedure RS_Circle(var CenP:TPoint1;var col:integer;var Radius:double;
                 var layer,linetype,handle:string);virtual;abstract;
    procedure Rs_Ellipse(var CenP,MayP:TPoint1;var col:integer;var RRatio,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);virtual;abstract;
    procedure RS_text(var InsP:TPoint1;var Text:string;var Height,Rotation:double;var col:integer;
                 var TextSty,layer,linetype,handle:string);virtual;abstract;
   private
   public
    AcadApp,AcadDoc,AcadDocs,AcadMod,AcadObj,ObjItem,ObjCount:olevariant;
    ObjItemId:integer;
  end;

  TGetCADData=class(TAcad)//获取CAD图形数据
    procedure RS_LineType(var LineTypes:TStrings);override;
    procedure RS_TextStyle(var TextSty,Fontf:TStrings);override;
    procedure RS_Layer(var layers:TStrings);override; //把图纸中的所有图层信息读入到Layers中
    procedure RS_line(var Sp,Ep:TPoint1;var col:integer;var layer,linetype,handle:string);override;
    procedure RS_3DPoly(var PCount:integer;var ListP:TPoints;var widList,BugList:TListvalue;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);override;
    procedure RS_Spline(var PCount:integer;var ListP:TPoints;var S_Tan,E_Tan:TPoint1;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);override;
    procedure RS_Arc(var CenP:TPoint1;var col:integer;var Radius,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);override;
    procedure RS_Circle(var CenP:TPoint1;var col:integer;var Radius:double;
                 var layer,linetype,handle:string);override;
    procedure Rs_Ellipse(var CenP,MayP:TPoint1;var col:integer;var RRatio,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);Override;
    procedure RS_text(var InsP:TPoint1;var Text:string;var Height,Rotation:double;
                 var col:integer;var TextSty,layer,linetype,handle:string);override;
   private
   public
  end;

  TSetCADData=class(TACAD)//绘制CAD图形
    procedure RS_Layer(var layers:TStrings);override;
    procedure RS_TextStyle(var TextSty,Fontf:TStrings);override;
    procedure RS_linetype(var LineTypes:TStrings);override;
    procedure RS_line(var Sp,Ep:TPoint1;var col:integer;var layer,linetype,handle:string);override;
    procedure RS_Pline(var PCount:integer; var ListP:TPoints;var widList,BugList:TListvalue;
                 var col:integer; var closed: boolean;var layer,linetype,handle: string);override;
    procedure RS_3DPoly(var PCount:integer;var ListP:TPoints;var widList,BugList:TListvalue;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);override;
    procedure RS_Spline(var PCount:integer;var ListP:TPoints;var S_Tan,E_Tan:TPoint1;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);override;
    procedure RS_Arc(var CenP:TPoint1;var col:integer;var Radius,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);override;
    procedure RS_Circle(var CenP:TPoint1;var col:integer;var Radius:double;
                 var layer,linetype,handle:string);override;
    procedure Rs_Ellipse(var CenP,MayP:TPoint1;var col:integer;var RRatio,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);override;
    procedure RS_text(var InsP:TPoint1;var Text:string;var Height,Rotation:double;
                 var col:integer;var TextSty,layer,linetype,handle:string);override;
   private
   public
  end;

  //Project对象模型
  TProject=class(tobject)
    function Link_Project:boolean;
    procedure CloseAll;
    procedure Add_Field(Id:integer;ProF,StrF:string); //添加文本域
    Procedure Add_Pro(DateStr:string);
    procedure Open_Pro(ProName:string);
    Procedure ChangeSys;
    procedure InputTask(TaskId:integer;AreaName,TaskName,Duration,
      StartDate,PreTask,resource,Salary,Material,Electricity,Equipment,
      Q,Fin_Dis:string;IsDown,IsUp:boolean);
    procedure OutputTask(TaskId:integer;AreaName,TaskName,Duration,
      StartDate,PreTask,resource,Salary,Material,Electricity,Equipment,
      Q,Fin_Dis:string);
    procedure InputResource(ResourceName:string);
    procedure OutputResource(ResId:integer;ResourceName:string);
   private
   public
    ProjectApp,ProjectObj:olevariant;
  end;

  TExcel=class(tobject)
    function Link_Excel:boolean;
    procedure Add_XslWorkBook(BookStr,SheetStr: string);
    procedure Open_XslWorkBook(BookStr: string);
    procedure Add_XslWorkSheet(SheetStr:string);
    procedure Add_Field(i,j:integer;CellStr:string); //添加文本域
    //procedure Open_Xsl(XslName:string);
   private
   public
    ExcelApp,Excelworkbooks,Excelworkbook
      ,ExcelworkSheets,ExcelworkSheet:olevariant;
  end;


  //calculate tool工具
  //判断两个整数数组是否相等，包含于或包含关系，不相等
  function Radian(Ang:double):double;  {角度-弧度}
  function Angle(Rad:double):double;  {弧度-角度}
  function Tan(Ang:double):double;{正切值}
  function DirectXY(StartP:TPoint1;Angle,Dis:double):TPoint1;{StartP以Angle走Dis到达的点}
  function Direct(StartP,EndP:TPoint1):double;{StartP--->EndP的矢量角}
  procedure find_insect(x1,x2,y1,y2:TPoint1;var p:TPoint1;var b:boolean); //求交点
  function Distance(StartP,EndP:TPoint1):double;{StartP,EndP两点距离}
  function MinDis(p,p1,p2:TPoint1):double;  //球一个点到一条线段的最短距离
  function PInP1P2(p,p1,p2:TPoint1):integer;{判断P是否位于线P1,P2上}
  function PInListP(Pcou:integer;Inp:TPoint1;ListP:TPoints):boolean;{判断一点是否在一个任意闭合多边形之内}
  function P1EqualP2(P1,P2:TPoint1):boolean;//判断两个点是否为同一个点
  procedure ExPoint(var StartP,EndP:TPoint1);{交换StartP,EndP}
  procedure ExString(var SStr,EStr:string); {交换字符串}
  procedure Exinteger(var Si,Ei:integer);   {交换两个整数}
  procedure ExDouble(var Sd,Ed:double); {交换两个实数}
  function DelSubStr(MonStr,SubStr:string):String;{在MonStr中删除SubStr}
  function GetStr(MonStr:string;SubStrB,SubStrE:string):string;{在MonStr中取字符串}
  function get_Year_days(y,m:integer):integer;//计算某年某月的天数

  //component tool
  function GetId(ADOTDB:TDataSet;fieldstr:string):integer;{获得数据表最后一条记录的fieldstr值}
  function EditIsNull(Edt:Tedit):boolean;
  function DBEditIsNull(DBEdt:TDBedit):boolean;
  function ComboBoxIsNull(CBox:TComboBox):boolean;
  function DBLookUpComboBoxIsNull(DBCBox:TDBLookupComboBox):boolean;
  function DBComboBoxIsNull(DBCBox:TDBComboBox):boolean;
  //System tool
  function CDMDDir(filestr:string):string;
  procedure ListDataS(DBLkUpCbx:TDBLookupComboBox;Ds:TDataSource;LField,KField:string);overload;
  procedure ListDataS(DBLkUpLbx:TDBLookupListBox;Ds:TDataSource;LField,KField:string);overload;
  function BlobContentToString(fileName:string):string;
  function StringToBlobContent(Tbl:TAdoTable;BlobF,Ext:string;OleCon:TOleContainer):string;
  function Confirm(Tbl:TDataSet):boolean;
  function DelRec(Tbl:TDataSet):boolean;
  //----------------平均值和方差-------------------------
  function Average(SCou:integer;Sam:Tlistvalue):double;
  function Sigma(SCou:integer;Sam:Tlistvalue):double;
  //-----------------拉格朗日插值----------------------------
  function the_para(PId,PCou:integer;TPs:TPoints):double;
  function the_re(Px:double;PCou:integer;TPs:TPoints):double;
 //-----------------------------------------------------

var Acad:TAcad; //利用动态编联来创建SetCADdata和GetCADdata对象,用完free
    Project:TProject;//在使用时Create,用完free
    Excel:TExcel;
    xy:TPoints;
implementation
 {uses AcadProject;}

{ TAcad }

function TAcad.Link_CAD:boolean;
begin
 result:=false;
 try
    AcadApp:=getactiveoleobject('Autocad.Application');
 except
    on eolesyserror do
        try
          //Frm_CADPro:= TFrm_CADPro.Create(Application);
          //with Frm_CADPro  do
           //begin
            //setvisible(true,false,false);
            //Show;
            //Update;
            AcadApp:=CreateOleObject('Autocad.Application');
            //Hide;
            //Free;
           //end;
        except
           showmessage('连接AutoCAD错误！！！');
           result:=true;
           exit;
        end;
 end;
 AcadApp.visible:=true;
 AcadDocs:=AcadApp.documents;
 AcadDoc:=AcadApp.activedocument;
 AcadMod:=AcadDoc.modelspace;
end;

procedure TAcad.CloseAll;
begin
 acadapp.documents.close;
end;

function TAcad.xyz_olevar(p: TPoint1): olevariant;
var tp:olevariant;
begin
 tp:=vararraycreate([0,2],vardouble);
 tp[0]:=p[0];
 tp[1]:=p[1];
 tp[2]:=p[2];
 result:=tp;
end;

procedure TAcad.Add_Doc(DocName: string);
begin
 AcadApp.documents.add(DocName);
 AcadDoc:=AcadApp.activedocument;
 AcadMod:=AcadDoc.modelspace;
end;

procedure TAcad.Cad_WinState(StateID: integer); //1,2,3
begin
 AcadApp.windowstate:=StateID;
end;

procedure TAcad.ZoomAll;
begin
 AcadApp.ZoomExtents;
end;

procedure TAcad.Open_doc(DocName: string);
begin
 AcadDocs.open(DocName);
 AcadDoc:=AcadApp.activedocument;
 AcadMod:=AcadDoc.modelspace;
end;

procedure TAcad.SetTxtStyle(Style: string);
begin
 AcadDoc.activetextstyle.fontfile:='宋体';
end;

{ TGetCADData }

procedure TGetCADData.RS_line(var Sp,Ep:TPoint1;var col:integer;
                      var layer,linetype,handle:string);
var Spp,Epp:olevariant;
    PId:integer;
begin
  Spp:=ObjItem.startPoint;
  Epp:=ObjItem.endPoint;
  for PId:=0 to 2 do
  begin
   Sp[PId]:=Spp[PId];
   Ep[PId]:=Epp[PId];
  end;
  col:=ObjItem.color;
  layer:=ObjItem.layer;
  linetype:=ObjItem.linetype;
  Handle:=ObjItem.handle;
end;

procedure TGetCADData.RS_3DPoly(var PCount:integer;var ListP:TPoints;var widList,BugList:TListvalue;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);
var DimVal,PId,Dim:integer;
    ListPoint:olevariant;
    Elevate:double;
begin
 ListPoint:=ObjItem.Coordinates;//获得顶点集合,如果是3DPoly则为三维，如为PLine则为二维
 if ObjItem.entityType=24
 then Dim:=2
 else Dim:=3;
 DimVal:=(VarArrayhighBound(ListPoint,1)+1) div Dim;
 setlength(ListP,DimVal);
 setlength(widList,2*DimVal);
 setlength(BugList,DimVal);
 PCount:=DimVal;
 for PId:=0 to DimVal-1 do
  begin
    if ObjItem.entityType=24 then
     begin
      Elevate:=ObjItem.Elevation;
      if PId<DimVal-1 then
       begin
        ObjItem.GetWidth(PId,widList[2*PId],widList[2*PId+1]);
        Buglist[PId]:=ObjItem.GetBulge(PId);
       end;
      ListP[PId,0]:=ListPoint[PId*2];
      ListP[PId,1]:=ListPoint[PId*2+1];
      ListP[PId,2]:=Elevate;
     end;
    if ObjItem.entityType=2 then
     begin
      ListP[PId,0]:=ListPoint[PId*3];
      ListP[PId,1]:=ListPoint[PId*3+1];
      ListP[PId,2]:=ListPoint[PId*3+2];
     end;
  end;
 col:=ObjItem.color;
 closed:=ObjItem.Closed;
 layer:=trim(ObjItem.layer);
 linetype:=trim(ObjItem.linetype);
 Handle:=ObjItem.handle;
end;

procedure TGetCADData.RS_Spline(var Pcount:integer;var ListP: TPoints;var S_Tan, E_Tan:TPoint1;
  var col:integer;var closed: boolean;var layer, linetype,handle: string);
var PId,i:integer;
    ListPoints,S_T,E_T:olevariant;
begin
  try
   S_T:=ObjItem.StartTangent;
   E_T:=ObjItem.EndTangent;
   PId:=ObjItem.NumberOfFitPoints;
   ListPoints:=ObjItem.FitPoints;
   for i:=0 to 2 do
    begin
     S_Tan[i]:=S_T[i];E_Tan[i]:=E_T[i];
    end;
  except
   PId:=ObjItem.NumberOfControlPoints;
   ListPoints:=ObjItem.ControlPoints;
   for i:=0 to 2 do
    begin
     S_Tan[i]:=ListPoints[i];E_Tan[i]:=ListPoints[PId*3-3+i];
    end; 
  end;
  setlength(ListP,PId);PCount:=PId;
  for i:=0 to PId-1 do
  begin
   ListP[i,0]:=ListPoints[i*3];
   ListP[i,1]:=ListPoints[i*3+1];
   ListP[i,2]:=ListPoints[i*3+2];
  end;
  col:=ObjItem.color;
  closed:=ObjItem.closed;
  layer:=trim(ObjItem.layer);
  linetype:=trim(ObjItem.linetype);
  Handle:=ObjItem.handle;
end;

procedure TGetCADData.RS_Arc(var CenP: TPoint1;var col: integer;var Radius, S_Ang,
  E_Ang: double;var layer, linetype,handle: string);
var CenPoint:olevariant;
    i:integer;
begin
  CenPoint:=ObjItem.Center;
  for i:=0 to 2 do CenP[i]:=CenPoint[i];
  col:=ObjItem.color;
  Radius:=ObjItem.Radius;
  S_Ang:=ObjItem.StartAngle;
  E_Ang:=ObjItem.EndAngle;
  layer:=trim(ObjItem.layer);
  linetype:=Trim(ObjItem.linetype);
  Handle:=ObjItem.handle;
end;

procedure TGetCADData.RS_Circle(var CenP: TPoint1;var col: integer;var Radius: double;
  var layer, linetype,handle: string);
var CenPoint:olevariant;
    i:integer;
begin
  CenPoint:=ObjItem.Center;
  for i:=0 to 2 do CenP[i]:=CenPoint[i];
  col:=ObjItem.color;
  Radius:=ObjItem.Radius;
  layer:=Trim(ObjItem.layer);
  linetype:=Trim(ObjItem.linetype);
  Handle:=ObjItem.handle;
end;

procedure TGetCADData.RS_text(var InsP: TPoint1;var Text: string;var  Height,
  Rotation: double;var col: integer;var TextSty, layer, linetype,handle: string);
var InsPoint:olevariant;
    i:integer;
begin
  InsPoint:=ObjItem.InsertionPoint;
  for i:=0 to 2 do InsP[i]:=InsPoint[i];
  Text:=Trim(ObjItem.TextString);
  if ObjItem.entityType=21 then Text:=GetStr(Text,';','}');
  Height:=ObjItem.Height;
  Rotation:=ObjItem.Rotation;
  col:=ObjItem.color;
  TextSty:=Trim(ObjItem.StyleName);
  layer:=Trim(ObjItem.layer);
  linetype:=Trim(ObjItem.linetype);
  Handle:=ObjItem.handle;
end;

procedure TGetCADData.RS_Layer(var Layers:TStrings); //把图纸中的所有图层信息读入到Layers中
var i:integer;
begin                              
  inherited;
  Layers:=TStringlist.Create;
  Layers.Clear;
  for i:=0 to AcadDoc.layers.count-1 do
   Layers.Add(trim(AcadDoc.Layers.item(i).name));
end;

procedure TGetCADData.RS_LineType(var LineTypes:TStrings);