unt_cad_pro_tool.pas

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

var i:integer;
begin
  inherited;
  LineTypes:=TStringlist.Create;
  LineTypes.Clear;
  for i:=0 to  AcadDoc.LineTypes.count-1 do
   LineTypes.Add(trim(AcadDoc.LineTypes.item(i).name));
end;

procedure TGetCADData.RS_TextStyle(var TextSty, Fontf: TStrings);
var i:integer;
begin
  inherited;
  TextSty:=TStringlist.Create;TextSty.Clear;
  Fontf:=TStringlist.Create;  Fontf.Clear;
  for i:=0 to AcadDoc.textstyles.count-1 do
   begin
    TextSty.Add(trim(AcadDoc.textstyles.item(i).name));
    Fontf.Add(trim(AcadDoc.textstyles.item(i).Fontfile))
   end;
end;

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

{ TSetCADData }

procedure TSetCADData.RS_layer(var layers: Tstrings);
var i:integer;
begin
 for i:=0 to Layers.Count-1 do
   AcadDoc.layers.add(layers.Strings[i]);
end;

procedure TSetCADData.RS_TextStyle(var TextSty, Fontf: TStrings);
//var i:integer;
begin
  inherited;
  {for i:=0 to TextSty.Count-1 do
   begin
    if TextSty.Strings[i]='STANDARD'
     then AcadDoc.TextStyles.item(i).fontfile:=fontf.Strings[i]
     else begin
           Acadobj:=AcadDoc.TextStyles.add(TextSty.Strings[i]);
           Acadobj.FontFile:=Fontf.Strings[i];
          end; 
   end;  }
end;

procedure TSetCADData.RS_linetype(var linetypes:TStrings);
var i:integer;
begin
 for i:=0 to LineTypes.Count-1 do
  AcadDoc.linetypes.load(linetypes.Strings[i],'acadiso.lin');
end;

procedure TSetCADData.RS_Pline(var PCount: integer; var ListP: TPoints;
  var widList, BugList: TListvalue; var col: integer; var closed: boolean;
  var layer, linetype,handle: string);
var i:integer;
    PArray:olevariant;
begin
  PArray:=vararraycreate([0,PCount*2-1],vardouble);
  for i:=0 to PCount-1 do
   begin
    PArray[i*2]:=ListP[i,0];
    PArray[i*2+1]:=ListP[i,1];
   end;
  AcadObj:=AcadMod.AddLightweightPolyline(PArray);
  for i:=0 to PCount-2 do
   begin
    AcadObj.SetBulge(i,BugList[i]);
    AcadObj.SetWidth(i,widList[2*i],widList[2*i+1]);
   end;
  AcadObj.Elevation:=ListP[0,2];
  AcadObj.color:=col;
  AcadObj.Closed:=Closed;
  AcadObj.layer:=layer;
  AcadObj.LineType:=LineType;
end;

procedure TSetCADData.RS_3DPoly(var PCount: integer; var ListP: TPoints;
  var widList, BugList: TListvalue; var col: integer; var closed: boolean;
  var layer, linetype,handle: string);
var i:integer;
    PArray:olevariant;
begin
  inherited;
  PArray:=vararraycreate([0,PCount*3-1],vardouble);
  for i:=0 to PCount-1 do
   begin
    PArray[i*3]:=ListP[i,0];
    PArray[i*3+1]:=ListP[i,1];
    PArray[i*3+2]:=ListP[i,2];
   end;
  AcadObj:=AcadMod.Add3Dpoly(PArray);
  AcadObj.color:=col;
  AcadObj.Closed:=Closed;
  AcadObj.layer:=layer;
  AcadObj.LineType:=LineType;
end;

procedure TSetCADData.RS_line(var Sp,Ep:TPoint1;var col:integer;
              var layer,linetype,handle:string);
begin
 Acadobj:=AcadMod.addline(xyz_olevar(Sp),xyz_olevar(Ep));
 Acadobj.color:=col;
 Acadobj.linetype:=Linetype;
 Acadobj.layer:=layer;
end;

procedure TSetCADData.RS_Arc(var CenP: TPoint1; var col: integer;
  var Radius, S_Ang, E_Ang: double; var layer, linetype,handle: string);
begin
  inherited;
  Acadobj:=AcadMod.addArc(xyz_olevar(CenP),Radius,S_Ang, E_Ang);
  Acadobj.color:=col;
  Acadobj.linetype:=Linetype;
  Acadobj.layer:=layer;
end;

procedure TSetCADData.RS_Circle(var CenP: TPoint1; var col: integer;
  var Radius: double; var layer, linetype,handle: string);
begin
  inherited;
  Acadobj:=AcadMod.addCircle(xyz_olevar(CenP),Radius);
  Acadobj.color:=col;
  Acadobj.linetype:=Linetype;
  Acadobj.layer:=layer;
end;

procedure TSetCADData.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 i:integer;
    PArray:olevariant;
begin
  inherited;
  PArray:=vararraycreate([0,PCount*3-1],vardouble);
  for i:=0 to PCount-1 do
   begin
    PArray[i*3]:=ListP[i,0];
    PArray[i*3+1]:=ListP[i,1];
    PArray[i*3+2]:=ListP[i,2];
   end;
  Acadobj:=AcadMod.AddSpline(PArray,xyz_olevar(S_Tan),xyz_olevar(E_Tan));
  Acadobj.color:=col;
  Acadobj.linetype:=Linetype;
  Acadobj.layer:=layer;
end;

procedure TSetCADData.RS_text(var InsP: TPoint1; var Text: string;
  var Height, Rotation: double; var col: integer; var TextSty, layer,
  linetype,handle: string);
begin
  inherited;
  Acadobj:=AcadMod.AddText(Text,xyz_olevar(InsP),Height);
  Acadobj.Rotation:=Rotation;
  //Acadobj.StyleName:=TextSty;
  Acadobj.color:=col;
  Acadobj.linetype:=Linetype;
  Acadobj.layer:=layer;
end;

procedure TSetCADData.Rs_Ellipse(var CenP, MayP: TPoint1;
  var col: integer; var RRatio,S_Ang, E_Ang: double; var layer, linetype,
  handle: string);
begin
  inherited;
  Acadobj:=AcadMod.AddEllipse(xyz_olevar(CenP),xyz_olevar(MayP),RRatio);
  Acadobj.color:=col;
  Acadobj.StartAngle:=S_Ang;
  Acadobj.EndAngle:=E_Ang;
  Acadobj.linetype:=Linetype;
  Acadobj.layer:=layer;
end;

{ TProject }

function TProject.Link_Project:boolean;
begin
 result:=false;
 try
    ProjectObj:=getactiveoleobject('MSProject.project');
 except
    on eolesyserror do
        try
          //Frm_CADPro:= TFrm_CADPro.Create(Application);
          //with Frm_CADPro do
           //begin
            //setvisible(false,true,false);
            //Show;
            //Update;
            ProjectObj:=CreateOleObject('MSProject.project');
            //Hide;
            //Free;
           //end;
        except
           showmessage('链接Project出错，请确认Project是否正确安装!!'); 
           result:=true;
           exit;
        end;
 end;
 ProjectApp:=ProjectObj.Application;
 ProjectApp.visible:=true;
 ProjectApp.AppMaximize;
end;

procedure TProject.CloseAll;
var i:integer;
begin
 i:=ProjectApp.projects.count;
 if i>1
 then  ProjectApp.filecloseall(0); //0表示关闭而不保存这个项目
end;

procedure TProject.Add_Field(Id:integer;ProF,StrF:string);
begin
 projectapp.TableEdit('项(&E)',True,false,false,'','',ProF,StrF,12,2,True,true,255,1,Id,1);
end;

procedure TProject.ChangeSys;
var i:integer;
begin
 ProjectApp.OptionsCalendar(false,1,'0','0',24,168);
 for i:=1 to 7 do
 begin
  ProjectApp.activeproject.Calendar.weekdays[i].working:=true;
  ProjectApp.activeproject.Calendar.weekdays[i].Shift1.Clear;
  ProjectApp.activeproject.Calendar.weekdays[i].Shift2.Clear;
  ProjectApp.activeproject.Calendar.weekdays[i].Shift3.Clear;
  ProjectApp.activeproject.Calendar.weekdays[i].Shift1.Start:='#0:00:00 AM#';//strtotime('0:00:00');
  ProjectApp.activeproject.Calendar.weekdays[i].Shift1.Finish:='#0:00:00 PM#';//strtotime('0:00:00');
 end;
end;

procedure TProject.Add_Pro(DateStr:string);
begin
 ProjectApp.filenew(false);//false表示不提示时间限制窗口
 ProjectApp.activeproject.ProjectStart:=DateStr;//'1999年2月5日';
end;

procedure TProject.Open_Pro(ProName: string);
begin
 Projectapp.fileopen(ProName);
end;

procedure TProject.InputTask(TaskId:integer;AreaName,TaskName,Duration,
      StartDate,PreTask,resource,Salary,Material,Electricity,Equipment,
      Q,Fin_Dis:string;IsDown,IsUp:boolean);
begin
 ProjectApp.activeproject.tasks.add(TaskName);
 if IsDown then ProjectApp.activeproject.tasks[TaskId].OutlineIndent;
 if IsUp then ProjectApp.activeproject.tasks[TaskId].OutlineOutdent;
 ProjectApp.activeproject.tasks[TaskId].text1:=AreaName;
 ProjectApp.activeproject.tasks[TaskId].Start:=StartDate;
 ProjectApp.activeproject.tasks[TaskId].Duration:=Duration;
 ProjectApp.activeproject.tasks[TaskId].Predecessors:=PreTask;
 ProjectApp.activeproject.tasks[TaskId].ResourceNames:=resource;
 ProjectApp.activeproject.tasks[TaskId].text2:=Salary;
 ProjectApp.activeproject.tasks[TaskId].text3:=Material;
 ProjectApp.activeproject.tasks[TaskId].text4:=Electricity;
 ProjectApp.activeproject.tasks[TaskId].text5:=Equipment;
 ProjectApp.activeproject.tasks[TaskId].text6:=Q;
 ProjectApp.activeproject.tasks[TaskId].text7:=Fin_Dis;
end;

procedure TProject.OutputTask(TaskId:integer;AreaName,TaskName,Duration,
      StartDate,PreTask,resource,Salary,Material,Electricity,Equipment,
      Q,Fin_Dis:string);
begin
 AreaName:=ProjectApp.activeproject.tasks[TaskId].text1;
 TaskName:=ProjectApp.activeproject.tasks[TaskId].name;
 StartDate:=ProjectApp.activeproject.tasks[TaskId].Start;
 Duration:=ProjectApp.activeproject.tasks[TaskId].Duration;
 PreTask:=ProjectApp.activeproject.tasks[TaskId].Predecessors;
 resource:=ProjectApp.activeproject.tasks[TaskId].ResourceNames;
 Salary:=ProjectApp.activeproject.tasks[TaskId].text2;
 Material:=ProjectApp.activeproject.tasks[TaskId].text3;
 Electricity:=ProjectApp.activeproject.tasks[TaskId].text4;
 Equipment:=ProjectApp.activeproject.tasks[TaskId].text5;
 Q:=ProjectApp.activeproject.tasks[TaskId].text6;
 Fin_Dis:=ProjectApp.activeproject.tasks[TaskId].text7;
end;

procedure TProject.InputResource(ResourceName: string);
begin
   projectapp.activeproject.Resources.add(ResourceName);
end;

procedure TProject.OutputResource(ResId:integer;ResourceName:string);
begin
  ResourceName:= projectapp.activeproject.Resources[ResId].name;
end;

{tool工具}

function Radian(Ang:double):double;  {角度-弧度}
begin
 result:=Ang*pi/180;
end;

function Angle(Rad:double):double;  {弧度-角度}
begin
 result:=Rad*180/pi;
end;

function Tan(Ang:double):double;
begin
 result:=sin(Ang)/cos(Ang);
end;

function DirectXY(StartP:TPoint1;Angle,Dis:double):TPoint1;
var CalP:TPoint1;
begin
 CalP[0]:=StartP[0]+dis*Cos(Angle);
 CalP[1]:=StartP[1]+dis*Sin(Angle);
 CalP[2]:=StartP[2];
 result:=CalP;
end;      

function Direct(StartP,EndP:TPoint1):double;
var t1,t2,t:double;
begin
 t:=0;//如果abs(t2)<1e-3 结果为0 ,[0,360)
 t1:=EndP[0]-StartP[0];t2:=EndP[1]-StartP[1];
 if t1>1e-3 then
 begin
  if t2>1e-3 then t:=arctan(t2/t1);
  if t2<-1e-3 then t:=2*pi+arctan(t2/t1);
 end;
 if t1<-1e-3 then t:=pi+arctan(t2/t1);
 if abs(t1)<1e-3 then
 begin
  if t2>1e-3 then t:=0.5*pi;
  if t2<-1e-3 then t:=1.5*pi;
 end;
 result:=t;
end;

procedure find_insect(x1,x2,y1,y2:TPoint1;var p:TPoint1;var b:boolean); //求交点
var kx,ky,alfx,alfy:double;
begin
 b:=false;
 alfx:=direct(x1,x2);alfy:=direct(y1,y2);
 if (abs(alfx-0.5*pi)<1e-3)or(abs(alfx-1.5*pi)<1e-3)
 then begin
        ky:=(y1[1]-y2[1])/(y1[0]-y2[0]);
        p[0]:=x1[0];
        if (abs(alfy)<1e-3)or(abs(alfy-pi)<1e-3)
        then p[1]:=y1[1]
        else p[1]:=y1[1]+ky*(p[0]-y1[0]);
        exit;
        p[2]:=x1[2];
      end;
 if (abs(alfy-0.5*pi)<1e-3)or(abs(alfy-1.5*pi)<1e-3)
 then begin
        kx:=(x1[1]-x2[1])/(x1[0]-x2[0]);
        p[0]:=Y1[0];
        if (abs(alfx)<1e-3)or(abs(alfx-pi)<1e-3)
        then p[1]:=x1[1]
        else p[1]:=x1[1]+kx*(p[0]-x1[0]);
        p[2]:=x1[2];
        exit;
      end;
 kx:=(x1[1]-x2[1])/(x1[0]-x2[0]);ky:=(y1[1]-y2[1])/(y1[0]-y2[0]);
 p[0]:=(x1[1]-y1[1]+ky*y1[0]-kx*x1[0])/(ky-kx);
 p[1]:=(ky*x1[1]-kx*y1[1]+kx*ky*y1[0]-kx*ky*x1[0])/(ky-kx);
 p[2]:=x1[2];
 if ((p[0]>x1[0])and(p[0]<x2[0]))or((p[0]<x1[0])and(p[0]>x2[0]))
 then begin
       if ((p[0]>y1[0])and(p[0]<y2[0]))or((p[0]<y1[0])and(p[0]>y2[0]))
          or((p[1]>y1[1])and(p[1]<y2[1]))or((p[1]<y1[1])and(p[1]>y2[1]))
       then b:=true;
      end;
 if ((p[1]>y1[1])and(p[1]<y2[1]))or((p[1]<y1[1])and(p[1]>y2[1]))
 then begin
       if ((p[0]>y1[0])and(p[0]<y2[0]))or((p[0]<y1[0])and(p[0]>y2[0]))
          or((p[1]>y1[1])and(p[1]<y2[1]))or((p[1]<y1[1])and(p[1]>y2[1]))
       then b:=true;
      end;
end;

function Distance(StartP,EndP:TPoint1):double;
var dis:double;
begin
 dis:=sqrt(sqr(StartP[0]-EndP[0])+sqr(StartP[1]-EndP[1]));
 result:=dis;
end;

function MinDis(p,p1,p2:TPoint1):double;
var alfa,dis,dis1,dis2,k,b:double;
    thep:TPoint1;
begin
  alfa:=direct(p1,p2);
  if (abs(alfa-0.5*pi)<1e-3)or(abs(alfa-1.5*pi)<1e-3)
  then begin
        if ((p[1]>p1[1])and(p[1]<p2[1]))or((p[1]<p1[1])and(p[1]>p2[1]))
        then dis:=abs(p[0]-p1[0])
        else begin
              dis1:=Distance(p,p1);dis2:=Distance(p,p2);
              dis:=dis1;
              if (dis-dis2)>1e-3 then dis:=dis2;
             end;
       end
  else if (abs(alfa)<1e-3)or(abs(alfa-pi)<1e-3)
       then begin
              if ((p[0]>p1[0])and(p[0]<p2[0]))or((p[0]<p1[0])and(p[0]>p2[0]))
              then dis:=abs(p[1]-p1[1])
              else begin
                    dis1:=Distance(p,p1);dis2:=Distance(p,p2);
                    dis:=dis1;
                    if (dis-dis2)>1e-3 then dis:=dis2;
                   end