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

转载 2004年07月05日 02:50:00


                      广州 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

OLE Automation一点粗浅认识

曾经为了办公自动化开发熬夜熬到了快要崩溃的地步,想想当时的痛苦,其实还是资料和经验都不足。 OLE Automation、ODBC、COM……其实,用哪种方式开发office系列产品的自动化软件都不要...
  • iceriver_1980
  • iceriver_1980
  • 2008年01月09日 13:51
  • 1240

OLE Automation (C#读取EXCEL)

object missing =System.Reflection.Missing.Value;             ApplicationClass app = newApplicatio...
  • s10141303
  • s10141303
  • 2013年02月01日 17:50
  • 1349

在Delphi中通过OLE方式写Excel文件

报表的打印是每个项目都会遇到的问题。由于报表格式要求五花八门,往往又同时要求打印格式可方便调整。作为一种替代方法,可以将需要打印的报表导出到Excel/Word,打印交给Office去吧。由于Offi...
  • tjianliang
  • tjianliang
  • 2006年10月18日 12:51
  • 3358

SQL Server 阻止了对组件 'Ole Automation Procedures' 的 过程'sys.sp_OACreate' 的访问

使用 Ole Automation Procedures 选项可指定是否可以在 Transact-SQL 批处理中实例化 OLE Automation 对象。还可以使用基于策略的管理或者sp_conf...
  • along_861
  • along_861
  • 2016年11月02日 15:37
  • 1099

SQL Server 阻止了对组件 'Ole Automation Procedures' 的 过程'sys.sp_OACreate' 的访问,因为此组件已作为此服务器安全配置的一部分而被关闭。系统管理员可以通过使用 sp_configure 启用 'Ol

错误: SQL Server 阻止了对组件 Ole Automation Procedures 的 过程sys.sp_OACreate 的访问,因为此组件已作为此服务器安全配置的一部分而被关闭。系统管...
  • IT_zen
  • IT_zen
  • 2007年03月29日 19:08
  • 17645

VB6在WIN7 64位下报automatic error的解决办法

VS6企业版可以在WIN7 64位下安装成功,但每次运行VB6时都要报错,Data View - Automation Error, Error accessing the OLE Registry...
  • oygy
  • oygy
  • 2013年09月29日 11:20
  • 4782

[转]DAO、RDO、ADO、OLE DB 、ODBC and JDB

DAO、RDO、ADO、OLE DB 、ODBC and JDB :ADO、DAO、RDO、ODBC、OLEDB、JDBC、BDE、数据库访问技术 摘自:http://topic.csdn.net...
  • yu0089
  • yu0089
  • 2013年06月09日 17:50
  • 1356

SQL Server 2008阻止了对组件 'Ole Automation Procedures' 的 过程'sys.sp_OACreate' 的访问,因为此组件已作为此服务器安全配置的一部分而被关闭

通过sql 存储过程将数据生成excel到指定目录 提示如下错误:  SQL Server 阻止了对组件 'Ole Automation Procedures' 的 过程'sys.sp_OACrea...
  • luck2018
  • luck2018
  • 2012年07月18日 15:49
  • 1033

Delphi OLE方法操作Excel

Delphi OLE方法操作Excel  来源:http://www.ltesting.net/ceshi/ruanjianceshikaifajishu/rjcskfyy/2008/0519/15...
  • chelen_jak
  • chelen_jak
  • 2011年12月12日 10:24
  • 4890

Automation Server Cannot Create Object解决方案 (引用)

Automation Server Cannot Create Object解决方案     [ 来自:中国软件开发实验室 ][昨天晚上,偶的脑袋突然闪了一下,好久没有解决的问题突然间来了思路,于是...
  • lovelyxc
  • lovelyxc
  • 2005年06月16日 14:51
  • 2001
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:用Ole Automation实现Delphi和AutoCad之间的数据交换
举报原因:
原因补充:

(最多只允许输入30个字)