?? 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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -