用Ole Automation实现Delphi和AutoCad之间的数据交换

广州 XD.W
AutoCad是一些做设计的朋友最常用软件之一，有时需要从AutoCad的图纸
中提取数据进行一些计算和优化工作，用手工进行提取工作量非常大；用AutoCad
的AutoLisp、ADS或者ObjectArx进行计算，对不熟悉的人来说掌握起来比较困难，
界面也不够友好。下面我们通过Ole Automation，利用Delphi来实现这一工作，
相关的AutoCad Automation信息请参见AutoCad的帮助文件acadauto.hlp。
首先在Delphi中建立一个新工程，在主Form放置三个TButton，分别命名为：
btnOpen，btnSend，btnGet，用于实现打开AutoCad，向Cad发送数据，从Cad提取
数据的功能，再放置一个TPaintBox，用于实现输出功能。下面是程序的主单元代码。
unit main;
interface
uses
file://在引用单元中要包含ComObj单元，用于支持Ole操作。
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComObj;
const
file://定义AutoCad中的实体类型常量，本程序中只用到直线，所以只定义了直线的类型常量。
acLine = 19;
type
file://定义程序中用到的数据结构
ZPoint = record
x,y: double;
end;
PZLine = ^ZLine;
ZLine = record
sp,ep: ZPoint;
next: PZLine;
end;
TForm1 = class(TForm)
Panel1: TPanel;
btnOpen: TButton;
BtnSend: TButton;
btnGet: TButton;
PaintBox1: TPaintBox;
procedure btnOpenClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure btnGetClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
file://存放数据的指针
pData: PZLine;
file://释放存放数据的内存
procedure FreeData;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FreeData;
var
pTmp: PZLine;
begin
file://释放数据链表内存
while pData <> nil do begin
pTmp := pData;
pData := pData^.next;
Dispose(pTmp);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
file://在主窗体的创建时初始化数据指针
pData := nil;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
file://在主窗体的销毁过程中释放内存
FreeData;
end;
file://打开AutoCad
procedure TForm1.btnOpenClick(Sender: TObject);
var
AcadApp : OleVariant;
begin
file://通过创建Ole Automation对象启动AutoCad
AcadApp := CreateOleObject('AutoCad.Application');
AcadApp.visible := true;
file://OleVariant数据类型是自动释放的，所以这里没有释放代码
end;
file://向AutoCad发送数据
procedure TForm1.btnSendClick(Sender: TObject);
var
AcadApp: OleVariant;
AcadDoc: OleVariant;
AcadMoSpace: OleVariant;
sp,ep: Variant;
pTmp: PZLine;
begin
file://得到已启动的AutoCad Application对象
AcadApp := GetActiveOleObject('AutoCad.Application');
file://得到AutoCad Document对象
AcadDoc := AcadApp.ActiveDocument;
file://得到AutoCad ModelSpace对象
AcadMoSpace := AcadDoc.ModelSpace;
file://遍历数据链表
pTmp := pData;
while pTmp <> nil do begin
file://创建包含数组的Variant变量sp，用于向AutoCad传递起点数据
sp := VarArrayCreate([0,2],VarDouble);
sp[0] := pTmp^.sp.x;
sp[1] := pTmp^.sp.y;
sp[2] := 0.0;
file://创建包含数组的Variant变量ep，用于向AutoCad传送终点数据
ep := VarArrayCreate([0,2],VarDouble);
ep[0] := pTmp^.ep.x;
ep[1] := pTmp^.ep.y;
ep[2] := 0.0;
file://VarArrayRef把包含数组的Variant变量转换成Variant数组，
file://使用AutoCad 14.0时要调用此函数，AutoCad 2000不需要
AcadMoSpace.AddLine(VarArrayRef(sp),VarArrayRef(ep));
pTmp := pTmp^.next;
end;
end;
file://从AutoCad提取数据
procedure TForm1.btnGetClick(Sender: TObject);
var
AcadApp: OleVariant;
AcadDoc: OleVariant;
AcadMoSpace: OleVariant;
AcadObj: OleVariant;
AcadPt: Variant;
i: integer;
EntiType: Integer;
pTmp: PZLine;
begin
file://得到所需的AutoCad对象
AcadApp := GetActiveOleObject('AutoCad.Application');
AcadDoc := AcadApp.ActiveDocument;
AcadMoSpace := AcadDoc.ModelSpace;
file://释放以前存放的数据
FreeData;
file://遍历模型空间中的每一个实体对象
for i := 0 to AcadMoSpace.Count-1 do begin
file://引用第i个实体对象
AcadObj := AcadMoSpace.Item(i);
file://提取实体类型
EntiType := AcadObj.EntityType;
file://判断是不是直线
if EntiType = acLine then begin
file://如果是直线，则提取相应的起点终点数据
new(pTmp);
AcadPt := AcadObj.StartPoint;
pTmp^.sp.x := AcadPt[0];
pTmp^.sp.y := AcadPt[1];
AcadPt := AcadObj.EndPoint;
pTmp^.ep.x := AcadPt[0];
pTmp^.ep.y := AcadPt[1];
pTmp^.next := pData;
pData := pTmp;
end;
end;
file://刷新用于显示结果的PaintBox
PaintBox1.Invalidate;
end;
file://显示提取的数据
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
MaxX, MaxY: double;
MinX, MinY: double;
pTmp: PZLine;
scale: double;
x,y: integer;
begin
pTmp := pData;
if pTmp = nil then exit;

file://计算放缩比例
MaxX := pTmp^.sp.x;
MinX := MaxX;
MaxY := pTmp^.sp.y;
MinY := MaxY;
while pTmp <> nil do begin
if MaxX < pTmp^.sp.x then MaxX := pTmp^.sp.x;
if MinX > pTmp^.sp.x then MinX := pTmp^.sp.x;
if MaxY < pTmp^.sp.y then MaxY := pTmp^.sp.y;
if MinY > pTmp^.sp.y then MinY := pTmp^.sp.y;
if MaxX < pTmp^.ep.x then MaxX := pTmp^.ep.x;
if MinX > pTmp^.ep.x then MinX := pTmp^.ep.x;
if MaxY < pTmp^.ep.y then MaxY := pTmp^.ep.y;
if MinY > pTmp^.ep.y then MinY := pTmp^.ep.y;
pTmp := pTmp^.next;
end;
scale := (PaintBox1.Width - 10) / (MaxX-MinX);
if scale > (PaintBox1.Height - 10) / (MaxY-MinY) then begin
scale := (PaintBox1.Height - 10) / (MaxY-MinY);
end;

file://显示提取的数据
pTmp := pData;
while pTmp <> nil do begin
x := round((pTmp^.sp.x - MinX) * scale) + 5;
y := PaintBox1.Height - (round((pTmp^.sp.y - MinY) * scale) + 5);
PaintBox1.Canvas.MoveTo(x,y);
x := round((pTmp^.ep.x - MinX) * scale) + 5;
y := PaintBox1.Height - (round((pTmp^.ep.y - MinY) * scale) + 5);
PaintBox1.Canvas.LineTo(x,y);
pTmp := pTmp^.next;
end;
end;
end.
本程序在PWin98se+Delphi5.0环境下编译通过，在AutoCad14.0、AutoCad2000
下运行通过，源代码可在此下载：http://wangxd.51.net/software/delphicad.zip。