cad二次开发基础教程和实例档.doc

大家知道什么是宏吗？说白它就是VBA过程。看下面的代码：Public Sub MacroDemo() MsgBox Hello,Welcome to AutoCAD VBA!End Sub这就是宏。打开CAD输入命令vbaide回车会出现VBA的编辑界面，双击ThisDrawing在右侧的代码区输入上面的代码。如下图：然后按F5键会出现宏窗口，如下图：点击运行，大家看到什么？这就是一个最简单的一个用VBA对CAD进行二次开发的程序，也就是宏那什么是VBA呢？VBA就是VB的一个子集它的全称是Visual Basic For Application,它具有VB的大部分功能。既然我们选择了VBA，我们首先要知道VBA能操作CAD里的哪些对象呢？打开VBAIDE窗口按下F2键会出现对象浏览器。如下图库选择AutoCAD,这时下面显示的就是CAD为VBA提供的可操作的对象的类了。这时有的人因没有基础，所以还是一头雾水，别怕，选中一个类图标后按F1，这时会弹出AutoCAD ActiveX and VBA Reference,选择最上面的一个子项Object Model(对象模型)，这个就是在CAD里那些对象的关系，如下图：如果英文不好的话，可以安装CAD2000,它的这个部分是中文的。为想学好VBA二次开发这个是必需的，而且VBA对Office的二次开发也是这样的。这个在编程界叫做Active X,包括Active X控件、Active X DLL、和Active X EXE就好比一个程序为其它程序提供的一个后门一样下面我就给大家讲一下菜单吧。因为我们用到的其它公司做CAD二次开发的插件，从直观上首先接触的就是它的菜单，刚开始用的时候就是从它的菜单开始接触的。我经常用到的做菜单的方法有两种，一种是用CAD的菜单文件，另一种就是用VBA代码直接长成菜单。我先介绍第一种，CAD的菜单文件它是文本文件，我们用记事本就可打开并编辑它，或者再重新创建一个说到这里有的人可能要问了，我应该从何处开始入手呢，要怎样做呢？别急，CAD本身就有现成的供我们参考，就放在CAD的安装文件夹下的Support文件夹内，或者其它插件的文件夹内，找不到可以按F3搜一下，扩展名分别为.mnu .mns ,mnc默认的菜单文件是 acad.mnu。原始 ASCII 菜单文件，即用户通常编辑或创建的文件。该文件以查看完整菜单文件的外表特征。.mnc已编译的菜单文件；一种二进制文件，包含用于定义菜单或其他界面元素的功能及外观的命令字符串和菜单语法。首次加载 MNU 文件时，AutoCAD 将编译此文件。.mns源菜单文件；一种与 MNU 文件相同的 ASCII 文件，但是不包含注释或特殊格式。每次菜单文件的内容被更改时，AutoCAD 将修改源菜单文件。.mnr菜单资源文件；一种二进制文件，包含由菜单或其他界面元素使用的位图。AutoCAD 每次编译 MNC 文件时，均生成菜单资源文件。.mnt菜单资源文件。仅在 MNR 文件无效（例如，只读）时生成该文件。.mnl菜单 LISP 文件；包含菜单文件使用的 AutoLISP 表达式。当加载与菜单 LISP 文件具有相同文件名的菜单文件时，AutoCAD 会将菜单 LISP 文件加载至内存。自己做的.mns的文件内容如下/ AutoCAD 菜单文件 - C:Documents and SettingswuypLocal SettingsApplication DataAutodeskAutoCAD 2004R16.0chsFD04Menu.mns/*MENUGROUP=wyp*POP1*WYPID_COMPUTE 富地2004(&C)ID_TongXin 通信. CTRL+SHIFT+ACC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/通信.dvb!Module1.TongXinID_WorkAffiliation 工作联系单.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!ModWorkAffiliation.WorkAffiliation ID_StyleBook 样本查询.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!ModStyleBook.StyleBookID_DRAW -绘图工具ID_ZISZERO 多义线各节点Z轴设为零CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/Z轴为0.dvb!Module1.SetZIs0ID_LuoXuanXian 三维螺旋线.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/螺旋线.dvb!Module1.LuoXuanXianID_JKX 设计工具ID_MXB 导出明细表.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!ModMXB.mxbID_YGXCKDGS 圆管型材宽度估算.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/圆管型材宽度估算.dvb!Module1.YGXCKDGSID_BKJQJS 圆管型材宽度精算. CTRL+SHIFT+SCC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/圆管型材宽度精算.dvb!Module1.BKJQJSID_NDJS 挠度计算. CTRL+SHIFT+CCC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/挠度计算.dvb!Module1.NDJSID_BULK1 体积. CTRL+SHIFT+ZCC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/体积.dvb!Module1.bulkID_LianLun 链轮参数CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/链轮参数.dvb!Module1.LianLunID_YLGBHJS 压力管壁厚计算.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/压力管壁厚计算.dvb!Module1.YLGBHJSID_GTBHJS 缸筒壁厚计算.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/缸筒壁厚计算.dvb!Module1.GTBHJSID_Bearing 轴承型号大全.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!ModBearing.BearingID_LiuLiang 油缸流量计算CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/流量计算.dvb!Module1.LiuLiangID_YYZHDJGL 液压站电机功率计算CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!modYYZHDJGL.YYZHDJGLid_GearMatching CAD系统设置ID_MButton -鼠标中键控制ID_MButtonPan 鼠标中键平移CC_setvar mbuttonpan 1ID_MButtonMenu 设置正角度的方向ID_anticlockwise 逆时针CC_setvar ANGDIR 0ID_deasil 隐含边延伸模式ID_extend 延伸(&E)CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!ModExtendMode.extendID_NoExtend 显示文件对话框ID_filediaON 显示CC_setvar filedia 1ID_filediaOFF 设置修剪和延伸的当前“投影”模式ID_PROJMODE0 真三维模式(无投影)CC_setvar PROJMODE 0ID_PROJMODE1 投影到当前UCS的XY平面上CC_setvar PROJMODE 1ID_PROJMODE2 预览图像是否随图形一起保存ID_RASTERPREVIEWOFF 不创建预览图像CC_setvar RASTERPREVIEW 0ID_RASTERPREVIEWON 寄出错误报告到ID_REPORTERRORON 显示CC_setvar REPORTERROR 1ID_REPORTERROROFF 双击鼠标编辑对象ID_PICKSTYLE_OK 使用CC_setvar PICKSTYLE 0ID_PICKSTYLE_NO -不使用CC_setvar PICKSTYLE 1ID_ANGBASE 基准角置零,图案为Ansi31CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!modCADSysVariant.AngBaseIs0ID_ZOOMFACTOR 鼠标辊抡缩放速度.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/鼠标辊抡缩放速度.dvb!Module1.SFSDID_HPNAME 设置默认填充图案为ANSI31CC_setvar HPNAME ansi31ID_CELTSCALE 设置当前对象的线型比例因子为1CC_setvar CELTSCALE 1 ID_QLHCHBC Windows系统工具ID_CALC 计算器. CTRL+SHIFT+ALT+ZCC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/winsystools.dvb!Module1.calcID_Mspaint 画笔. CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/winsystools.dvb!Module1.mspaintID_CALC1 实用计算器.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/winsystools.dvb!Module1.calc1ID_ChangeWPaper 电话表ID_FDTel 公司电话表.CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!modTel.FDTelID_ZHGTel 菜单ID_Update CAD2002菜单更新CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/UpdateFDMenu.dvb!Module1.Update02menuID_Update04 这句是在CAD中的菜单组名*POP1 这行为弹出菜单标识pop加上数字至于此部分的说明如下：/*MENUGROUP 菜单组名*BUTTONSn 定点设备按钮菜单*AUXn 系统定点设备菜单*POPn 下拉菜单和快捷菜单*TOOLBARS 工具栏定义*IMAGE 图像控件菜单*SCREEN 屏幕菜单*TABLETn 数字化仪菜单*HELPSTRINGS 当亮显下拉菜单或快捷菜单项时，或者当光标位于工具栏按钮上时，显示状态栏中的文字*ACCELERATORS 快捷键（或加速键）定义/下面这句就开始定义菜单上的项目了ID_COMPUTE 富地2004(&C)其中前面的ID_COMPUTE就是这个菜单项的唯一的标识，方括号内的就是菜单上显示的内容了，括号内的那个连字符加上一个字母C，它在菜单上会显示C下面带一个下划线，这个就是我们定义的热键，当屏幕显示此菜单时我们按Alt+C键时，就相当于我们用鼠标点击此菜单，在这行的后面我们什么也没加，是因为这是菜单的第一个项，因此不需要它做什么下一行的后面的这个CC-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/通信.dvb!Module1.TongXin 是我们点击此菜单项所执行的动作，前面的CC是相当于按了两次Esc键，主要是为了取消前一个正在运行的命令，下面的-vbarun是运行VBA程序的命令，再后面的的就是这个VBA宏文件的路径和名称了，如果将此宏文件的路径加到CAD支持文件的搜索路径内，就可以去掉前面的路径了。要注意的是在后面的行中的方括号内有-和鼠标中键控制ID_MButtonPan 鼠标中键平移CC_setvar mbuttonpan 1ID_MButtonMenu 显示文件对话框ID_filediaON 显示CC_setvar filedia 1ID_filediaOFF -不显示CC_setvar filedia 0ID_ZOOMFACTOR 鼠标辊抡缩放速度.CC-vbarun c:/Tests.dvb!Module1.SFSDID_CALC 计算器.CC-vbarun C:/Tests.dvb!Module1.calcID_CIRCLE 画圆.CC-vbarun C:/Tests.dvb!Module1.circlesID_MENUUPDATE 菜单更新CC-vbarun C:/Tests.dvb!Module1.updatemenus*TOOLBARS*HELPSTRINGSID_CALC 打开计算器ID_MButtonPan 当按下鼠标中键平移视口ID_MButtonMenu 当按下鼠标中键弹出菜单ID_filediaON 当对文件进行操作时打显示件对话框ID_filediaOFF 当对文件进行操作时显示文件对话框ID_ZOOMFACTOR 设置鼠标辊轮的缩放速度ID_CIRCLE 画一个圆ID_MENUUPDATE 从菜单文件更新此菜单VBA源程序文件名为Tests.dvb放在C盘根目录，里面添加一个模块，名为Module1,两个窗体分别名为frmCircle和frmMouseModule1里面的代码为下面内容：Option ExplicitDim MnuGroup As AcadMenuGroupPublic Enum enuLineType ltContinuous = 0 ltCenter = 1 ltDASHED = 2 ltPHANTOM = 3End EnumPublic Sub calc()Shell calc.exe, vbNormalFocusEnd SubPublic Sub SFSD()frmMouse.ShowEnd SubPublic Sub Circles()frmCircle.ShowEnd SubPublic Sub UpdateMenu()End Sub判断图层是否存在Public Function LayerExist(ByVal strLayerName As String) As BooleanDim objLayer As AcadLayerFor Each objLayer In ThisDrawing.Layers If objLayer.Name = strLayerName Then LayerExist = True Exit For End If NextEnd Function添加图层Public Function AddLayers(ByVal strLayerName As String, LineType As enuLineType, lColor As ACAD_COLOR, lineWeight As AcLineWeight) As AcadLayerDim objLayer As AcadLayerOn Error GoTo LineErrorSet objLayer = ThisDrawing.Layers.Add(strLayerName)If LineTypeExist(LineType) = False Then ThisDrawing.Linetypes.Load GetLineTypeString(LineType), acadiso.lin 添加线型End IfobjLayer.LineType = GetLineTypeString(LineType)objLayer.color = lColorobjLayer.lineWeight = lineWeightSet AddLayers = objLayerExit FunctionLineError:MsgBox Err.Number & Chr(13) & Err.Description, 16End Function获得图层Public Function GetLayer(ByVal strLayerName As String) As AcadLayerDim objLayer As AcadLayerFor Each objLayer In ThisDrawing.Layers If objLayer.Name = strLayerName Then Set GetLayer = objLayer Exit For End If NextEnd Function判断线型是否存在Private Function LineTypeExist(ByVal LineTypeName As enuLineType) As BooleanDim objLineType As AcadLineTypeFor Each objLineType In ThisDrawing.Linetypes If objLineType.Name = GetLineTypeString(LineTypeName) Then LineTypeExist = True Exit For End If NextEnd FunctionPrivate Function GetLineTypeString(ByVal LineType As enuLineType) As String Select Case LineType Case Is = ltContinuous GetLineTypeString = Continuous Case Is = ltCenter GetLineTypeString = CENTER Case Is = ltDASHED GetLineTypeString = DASHED Case Is = ltPHANTOM GetLineTypeString = PHANTOM End SelectEnd FunctionPublic Sub UpdateMenus()On Error Resume NextApplication.MenuGroups.Item(Test).UnloadApplication.MenuGroups.Load c:Test.mnsSet MnuGroup = Application.MenuGroups.Item(Test)MnuGroup.Menus.InsertMenuInMenuBar Test(&T), Application.MenuBar.Count + 1End SubfrmCircle的窗体内容为窗体内的代码为：Option ExplicitDim dblPoints(2) As Double, dblR As DoublePrivate Sub cmdOK_Click()Dim objCircle As AcadCircleDim objLayer As AcadLayer, objOldLayer As AcadLayerDim dblStart(2) As Double, dblEnd(2) As Double, dblExtend As DoubledblPoints(0) = Val(txtX.Text)dblPoints(1) = Val(txtY.Text)dblPoints(2) = Val(txtZ.Text)dblR = Val(txtR.Text)dblExtend = Val(TxtExtend.Text)If LayerExist(轮廓线层) = False Then Set objLayer = AddLayers(轮廓线层, ltContinuous, acWhite, acLnWtByLwDefault) 添加轮廓线层Else Set objLayer = GetLayer(轮廓线层)End IfSet objOldLayer = ThisDrawing.ActiveLayer 保存原来的图层ThisDrawing.ActiveLayer = objLayer 设置轮廓线层为当前层Set objCircle = ThisDrawing.ModelSpace.AddCircle(dblPoints, Val(txtR.Text) 画圆If LayerExist(中心线层) = False Then Set objLayer = AddLayers(中心线层, ltCenter, acRed, acLnWtByLwDefault) 添加中心线层Else Set objLayer = GetLayer(中心线层)End IfThisDrawing.ActiveLayer = objLayer 设置中心线层为当前层dblStart(0) = dblPoints(0) - dblR - dblExtenddblStart(1) = dblPoints(1)dblStart(2) = dblPoints(2)dblEnd(0) = dblPoints(0) + db