Delphi进行CAD二次开发教学（1）——基础学习：运行、新建、打开图形文件

最新推荐文章于 2024-09-08 15:48:36 发布

sunshinegyy

最新推荐文章于 2024-09-08 15:48:36 发布

阅读量4.7k

点赞数 1

分类专栏：学习文章标签：图形 delphi 文档 timer function imagelist

学习专栏收录该内容

2 篇文章 0 订阅

订阅专栏

http://hi.baidu.com/piaoliuxia/blog/item/d61e03faed3bd18c9f514670.html

查看文章

【原创】Delphi进行CAD二次开发教学（1）——基础学习：运行、新建、打开图形文件

2008-06-13 22:24

//用到了Rz控件，请自行安装，若没有可以到盒子下载，也可以不用此控件，但代码要相应修改。

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComObj, AutoCAD_TLB, ComCtrls, RzLabel, ExtCtrls, ActiveX,
RzButton, ImgList, RzStatus, RzPanel, ActnList, Mask, RzEdit, RzBorder;

type
TForm1 = class(TForm)
    Timer1: TTimer;
    RzToolbar1: TRzToolbar;
    RzStatusBar1: TRzStatusBar;
    RzStatusPane1: TRzStatusPane;
    RzClockStatus1: TRzClockStatus;
    ImageList1: TImageList;
    BtnSendtoBack: TRzToolButton;
    BtnNew: TRzToolButton;
    BtnOpen: TRzToolButton;
    BtnSave: TRzToolButton;
    ActionList1: TActionList;
    Act_CadApp: TAction;
    Act_NewDrawing: TAction;
    Act_OpenDrawing: TAction;
    Act_SaveDrawing: TAction;
    SaveDialog1: TSaveDialog;
    OpenDialog1: TOpenDialog;
    RzGlyphStatus1: TRzGlyphStatus;
    Act_ZoomAll: TAction;
    Act_ZoomWindow: TAction;
    Act_ZoomPrevious: TAction;
    Act_ZoomExtents: TAction;
    procedure Timer1Timer(Sender: TObject);
    procedure Act_CadAppExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Act_NewDrawingExecute(Sender: TObject);
    procedure Act_OpenDrawingExecute(Sender: TObject);
    procedure Act_SaveDrawingExecute(Sender: TObject);
    procedure Act_ZoomAllExecute(Sender: TObject);
    procedure Act_ZoomPreviousExecute(Sender: TObject);
    procedure Act_ZoomExtentsExecute(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;

var
Form1: TForm1;
Cad, ActDrawing: OleVariant;
BlockSet: Olevariant;
Tip: string;
implementation

{$R *.dfm}

//判断应用程序是否在运行

function IsObjectActive(ClassName: string): Boolean;
var
ClassID: TCLSID;
Unknown: IUnknown;
begin
try
    ClassID := ProgIDToClassID(ClassName);
    Result := GetActiveObject(ClassID, nil, Unknown) = S_OK;
except
    Result := False;
end;
end;

//判断CAD应用程序是否在运行

procedure GetCADapp();
begin
if IsObjectActive('AutoCAD.Application') then
begin
    Cad := GetActiveOleObject('AutoCAD.Application');
    Form1.RzGlyphStatus1.ImageIndex := 14;
end
else
begin
    Tip := 'AutoCAD没有运行！';
    cad := null;
    Form1.RzGlyphStatus1.ImageIndex := 12;
end;
end;

//打开新的CAD应用程序

function OpenCadapp(): boolean;
begin
try
    cad := createOleObject('AutoCAD.Application');
    result := true;
except
    cad := null;
    MessageBox(0, '系统没有安装AutoCAD，或者AutoCAD版本不适合，请检查！' + #13 +
      #10 + '（需要AutoCAD2004或AutoCAD2005）', '错误提示', MB_ICONERROR or
      MB_OK);
    result := false;
end;
end;

//获取当前的图纸文档

procedure GetActDrawing();
var
SS: string;
begin
try
    ActDrawing := cad.activedocument;
    SS := ActDrawing.fullname;
    if SS = '' then
      Tip := '当前文档：未保存，请尽快保存！'
    else
      Tip := '当前文档：' + SS;
except
    ActDrawing := null;
    Tip := '当前文档：无';
end;
end;

//打开已有的图形文件

function OpenDrawing(Drawing, Password: string): boolean;
begin
try
    ActDrawing := cad.documents.open(Drawing, false, Password);
    Tip := '当前文档：' + ActDrawing.fullname;
    result := true;
except
    ActDrawing := null;
    Tip := '打开图形文档失败！';
    result := false;
end;
end;
//新建图形文档

function NewDrawing(): boolean; //打开已有的图形文件
begin
try
    ActDrawing := cad.documents.add();
    //ActDrawing.saveas('c:/Drawing_Temp.dwg');
    Tip := '当前文档：未保存';
    result := true;
except
    ActDrawing := null;
    result := false;
end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
GetCADapp;
GetActDrawing;
RzStatusPane1.Caption := Tip;
end;

procedure TForm1.Act_CadAppExecute(Sender: TObject);
begin
if (vartype(Cad) = varnull) or (Vartype(cad) = varEmpty) then
begin
    if not OpenCadapp then
    begin
      Tip := '系统没有安装AutoCAD，或者AutoCAD版本不适合，请检查确认！';
      exit;
    end;
end
else
begin
    MessageBox(0, 'AutoCAD已经在运行了！', '提示：', MB_ICONINFORMATION or
      MB_OK);
    exit;
end;

cad.WindowState := $00000003;
//最大化 (acmax--$00000003,acmin--$00000002,acnorm--$00000001)
cad.Visible := true; //设置为可视

GetActDrawing; //获取当前活动图形文档

if vartype(ActDrawing) = varnull then

    if (MessageBox(0, '当前没有打开的图形文件！' + #13 + #10 +
      '要现在就新建一个吗？', '提示：', MB_ICONEXCLAMATION or MB_YESNO) = idYes)
        then
      NewDrawing()
    else
    begin
      Tip := '当前没有打开的图形文件，请新建或者打开已有的图形文件！';
      exit;
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
GetCadapp;
end;

procedure TForm1.Act_NewDrawingExecute(Sender: TObject);
begin
if (vartype(Cad) = varnull) or (Vartype(cad) = varEmpty) then
    MessageBox(0, '请先运行AutoCAD程序！', '警告：', MB_ICONWARNING or MB_OK)
else
    NewDrawing;
end;

procedure TForm1.Act_OpenDrawingExecute(Sender: TObject);
begin
if (vartype(Cad) = varnull) or (Vartype(cad) = varEmpty) then
    MessageBox(0, '请先运行AutoCAD程序！', '警告：', MB_ICONWARNING or MB_OK)
else
begin
    if OpenDialog1.Execute then
      OpenDrawing(OpenDialog1.FileName, '');
end;
end;

procedure TForm1.Act_SaveDrawingExecute(Sender: TObject);
begin
if (vartype(ActDrawing) = varnull) or (Vartype(ActDrawing) = varEmpty) then
begin
    MessageBox(0, '没有活动的图形文档！', '警告：', MB_ICONWARNING or MB_OK);
    exit;
end
else
begin
    if Savedialog1.Execute then
      ActDrawing.saveas(Savedialog1.FileName);
end;
end;

procedure TForm1.Act_ZoomAllExecute(Sender: TObject);
begin
Cad.zoomall;
end;

procedure TForm1.Act_ZoomPreviousExecute(Sender: TObject);
begin
Cad.ZoomPrevious;
end;

procedure TForm1.Act_ZoomExtentsExecute(Sender: TObject);
begin
Cad.ZoomExtents;
end;

end.