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

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

 

 

 

查看文章
 
【原创】Delphi进行CAD二次开发教学(1)——基础学习:运行、新建、打开图形文件
2008-06-13 22:24


c9f64009236173bb2eddd4e1.jpg

//用到了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.
展开阅读全文

没有更多推荐了,返回首页