{**********************************************}
{本單元主要包含AutoCAD、Project的數據導入和導出}
{過程以及一些通用的計算工具供圖形數據讀取和處理}
{生產過程模擬和動態演示用                      }
{**********************************************}

unit CAD_Pro_Exc_Unt; //Delphi調用AutoCAD2000、Project98、EXcel2000的工具

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;

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

  DListValue=array of array of double;

  TIdSide=record
        PCou:integer;//一邊點的個數
        Ps:TPoints; //具體點坐標  array of TPoint
    end;
  TIdSides=record
        LsPsCou:integer;//邊的個數
        LsPs:array of TIdSide; //具體邊情況
    end;

  //AutoCAD對象模型
  TAcad=class(Tobject)
    function Link_CAD:Boolean; //若連接正確，值為true，否則為false
    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:TPoint):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:TPoint;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:TPoint;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);virtual;abstract;
    procedure RS_Arc(var CenP:TPoint;var col:integer;var Radius,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);virtual;abstract;
    procedure RS_Circle(var CenP:TPoint;var col:integer;var Radius:double;
                 var layer,linetype,handle:string);virtual;abstract;
    procedure Rs_Ellipse(var CenP,MayP:TPoint;var col:integer;var RRatio,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);virtual;abstract;
    procedure RS_text(var InsP:TPoint;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;
    procedure RS_line(var Sp,Ep:TPoint;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:TPoint;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);override;
    procedure RS_Arc(var CenP:TPoint;var col:integer;var Radius,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);override;
    procedure RS_Circle(var CenP:TPoint;var col:integer;var Radius:double;
                 var layer,linetype,handle:string);override;
    procedure Rs_Ellipse(var CenP,MayP:TPoint;var col:integer;var RRatio,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);Override;
    procedure RS_text(var InsP:TPoint;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:TPoint;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:TPoint;var col:integer;
                 var closed:boolean;var layer,linetype,handle:string);override;
    procedure RS_Arc(var CenP:TPoint;var col:integer;var Radius,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);override;
    procedure RS_Circle(var CenP:TPoint;var col:integer;var Radius:double;
                 var layer,linetype,handle:string);override;
    procedure Rs_Ellipse(var CenP,MayP:TPoint;var col:integer;var RRatio,S_Ang,E_Ang:double;
                 var layer,linetype,handle:string);override;
    procedure RS_text(var InsP:TPoint;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; //若連接正確，值為true，否則為false
    procedure CloseAll;
  //Id:插入位置編號。當值為1時，在第2列位置插入新列，當值為－1時在現有表的最后一列插入新列
  //ProF:插入的新列的標志名稱，唯一
  //StrF:插入的新列的顯示名稱
    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; //若連接正確，值為true，否則為false
    procedure Add_XslWorkBook(BookStr,SheetStr: string);
    procedure Open_XslWorkBook(BookStr: string);
    procedure Add_XslWorkSheet(SheetStr:string);
    procedure Add_Field(i,j:integer;CellStr:string); //添加文本域
   private
   public
    ExcelApp,Excelworkbooks,Excelworkbook:olevariant;
    ExcelworkSheets,ExcelworkSheet:olevariant;
  end;


  //calculate tool工具
  //判斷兩個整數數組是否相等，包含于或包含關系，不相等
  function Radian(Ang:double):double;  {角度-弧度}
  function Angle(Rad:double):double;  {弧度-角度}
  function Tan(Ang:double):double;{正切值}
  function DirectXY(StartP:TPoint;Angle,Dis:double):Tpoint;{StartP以Angle走Dis到達的點}
  function Direct(StartP,EndP:TPoint):double;{StartP--->EndP的矢量角}
  function Distance(StartP,EndP:TPoint):double;{StartP,EndP兩點距離}
  function MinDis(p,p1,p2:TPoint):double;  //球一個點到一條線段的最短距離
  function PInP1P2(p,p1,p2:TPoint):integer;{判斷P是否位于線P1,P2上}
  function PInListP(Pcou:integer;Inp:TPoint;ListP:TPoints):boolean;{判斷一點是否在一個任意閉合多邊形之內}
  function P1EqualP2(P1,P2:TPoint):boolean;//判斷兩個點是否為同一個點
  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;//計算某年某月的天數

  procedure find_insect(x1,x2,y1,y2:Tpoint;var p:Tpoint;var b:boolean); //求交點
  procedure ExPoint(var StartP,EndP:TPoint);{交換StartP,EndP}
  procedure ExString(var SStr,EStr:string); {交換字符串}
  procedure Exinteger(var Si,Ei:integer);   {交換兩個整數}
  procedure ExDouble(var Sd,Ed:double); {交換兩個實數}

  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

{ TAcad }

function TAcad.Link_CAD:boolean;
begin
 result:=true;
 try
    AcadApp:=getactiveoleobject('Autocad.Application');
 except
    on eolesyserror do
        try
          AcadApp:=CreateOleObject('Autocad.Application');
        except
           showmessage('連接AutoCAD錯誤！！！');
           result:=false;
           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: TPoint): 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:TPoint;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:TPoint;
  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: TPoint;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: TPoint;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: TPoint;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);
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));