|
|
发表于 2005-6-30 22:37:00
|
显示全部楼层
都是自己摸索的，也没弄几天，仅供参考
可实现的功能：打开已有CAD文档，画直线，写文本，画多线，选择图层。
因为我的工作中只需用到这些功能，所以其他功能我都没写。大家有兴趣可以补充。
版本说明：delphi必须7.0以上。否则不行。
CAD我用的是2004
准备工作：打开DELPHI，project---〉import typelibrary 点ADD，添加C:\Program Files\Common Files\Autodesk Shared\acax16chs.tlb。install。
下面是程序，都是基于VBA的，和VBA相似
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComObj, AutoCAD_TLB;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
ComboBox1: TComboBox;
procedure Button1Click(Sender: TObject);
function drawline(a1,b1,a2,b2:Real;layers:string):Boolean;
function drawtext(text:string;a,b:Real;high:Real;flag:Boolean;layers:string):Boolean;
function drawwideline(a1,b1,a2,b2,a3,b3,a4,b4,a5,b5:Real;flag:boolean;layers:string):Boolean;
function drawrectangle(a1,b1,a2,b2:Real;flag:boolean;layers:string):Boolean;
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;line:Acadline;acad:AcadApplication;aPolygon: AcadLWPolyline;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var fangxiangtxt:Boolean;
begin
try
acad:=GetActiveOleObject('AutoCAD.Application.16') as AcadApplication;
except
acad:=CreateOleObject('AutoCAD.Application.16') as AcadApplication;
end;
Acad.Documents.Open('D:\1.dwg',false,false); //打开CAD；参数：（路径，是否只读，是否加密）,没有这句就是新建CAD
acad.Visible:=True;
drawline(0,0,100,100,'SB'); //画直线;参数：(起点（x，y）、终点（x，y）、图层)
drawtext('asds//adas',100,100,20,false,'SB');//写文本;参数：（文本，坐标，高度，横/竖，图层）
drawrectangle(0,0,100,100,true,'SB')// 画矩形；参数：（对角两点的坐标，粗/细，图层）
end;
function TForm1.drawline(a1,b1,a2,b2:Real;layers:string):Boolean;
var vpoint1,vpoint2:OleVariant;
begin
vpoint1:=varArrayCreate([0,2],varDouble);
vpoint2:=varArrayCreate([0,2],varDouble);
vpoint1[0]:=a1; vpoint1[1]:=b1; vpoint1[2]:=0;
vpoint2[0]:=a2; vpoint2[1]:=b2; vpoint2[2]:=0;
line:=acad.ActiveDocument.ModelSpace.Addline(vpoint1,vpoint2);
line.Layer:=layers;
line.Update;
end;
function TForm1.drawtext(text:string;a,b:Real;high:Real;flag:Boolean;layers:string):Boolean;
var vpoint:OleVariant;cc:widestring;bb:wordbool;dd:wordbool;ee:integer;ff:integer;
begin
vpoint:=varArrayCreate([0,2],varDouble);
vpoint[0]:=a; vpoint[1]:=b; vpoint[2]:=0;
flag:=false;
if flag then
begin
acad.ActiveDocument.ActiveTextStyle.setFont(cc,bb,dd,ee,ff);
acad.ActiveDocument.ModelSpace.Addtext(text,vpoint,high).Layer:=layers;
end
else// 本来想用这段实现从上到下排列的单行文字但是未果，
begin
acad.ActiveDocument.ActiveTextStyle.FontFile:='C:\Program Files\AutoCAD 2004\Fonts\txt.shx';
acad.ActiveDocument.ModelSpace.Addtext(text,vpoint,high).VerticalAlignment:=acVerticalAlignmentMiddle;
end;
//acad.ActiveDocument.ModelSpace.AddText()
//
//edit1.text:=cc;
end;
function Tform1.drawwideline(a1,b1,a2,b2,a3,b3,a4,b4,a5,b5:Real;flag:boolean;layers:string):Boolean;
var pline:OleVariant ;
begin
pline:=varArrayCreate([0,9],varDouble);
pline[0]:=a1; pline[1]:=b1; pline[2]:=a2; pline[3]:=b2; pline[4]:=a3; pline[5]:=b3;
pline[6]:=a4; pline[7]:=b4; pline[8]:=a5; pline[9]:=b5;
if flag then
begin
aPolygon:=acad.ActiveDocument.ModelSpace.AddLightWeightPolyline(pline);
aPolygon.ConstantWidth:=10;
aPolygon.Layer:=layers;
end
else
begin
aPolygon:=acad.ActiveDocument.ModelSpace.AddLightWeightPolyline(pline);
aPolygon.Layer:=layers;
end;
// acad.ActiveDocument.ModelSpace.AddMLine(pline)//多线，两条平行的，只要指定2个点；
end;
function Tform1.drawrectangle(a1,b1,a2,b2:Real;flag:boolean;layers:string):Boolean;
begin
drawwideline(a1,b1,a1,b2,a2,b2,a2,b1,a1,b1,flag,layers);
end;
end.
以上程序调试，运行成功
|
|
置顶卡
