您的位置：首页 > 编程语言 > Delphi

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

2008-11-19 08:48 661 查看

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.

内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理

标签：

相关文章推荐

新的分享

章节导航