VBA开发CAD经验.pdf

大家知道什么是宏吗 说白它就是 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 Settings wuyp Local Settings Application Data Autodesk AutoCAD 2004 R16 0 chs FD04Menu mns MENUGROUP wyp POP1 WYP ID COMPUTE 富地 2004 C ID TongXin 通信 CTRL SHIFT A C C vbarun F 编程 作品 CAD 二次开发 二次 开发 Vba 计算 通信 dvb Module1 TongXin ID WorkAffiliation 工作联系单 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 AcadVBA dvb ModWorkAffiliation WorkAffiliation ID StyleBook 样本查询 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计 算 AcadVBA dvb ModStyleBook StyleBook ID DRAW 绘图工具 ID ZISZERO 多义线各节点 Z 轴设为零 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 Z 轴为 0 dvb Module1 SetZIs0 ID LuoXuanXian 三维螺旋线 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 螺旋线 dvb Module1 LuoXuanXian ID JKX 设计工具 ID MXB 导出明细表 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 AcadVBA dvb ModMXB mxb ID YGXCKDGS 圆管型材宽度估算 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 圆管型材宽度估算 dvb Module1 YGXCKDGS ID BKJQJS 圆管型材宽度精算 CTRL SHIFT S C C vbarun F 编程 作品 CAD 二 次开发 二次开发 Vba 计算 圆管型材宽度精算 dvb Module1 BKJQJS ID NDJS 挠度计算 CTRL SHIFT C C C vbarun F 编程 作品 CAD 二次开 发 二次开发 Vba 计算 挠度计算 dvb Module1 NDJS ID BULK1 体积 CTRL SHIFT Z C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 体积 dvb Module1 bulk ID LianLun 链轮参数 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计 算 链轮参数 dvb Module1 LianLun ID YLGBHJS 压力管壁厚计算 C C vbarun F 编程 作品 CAD 二次开发 二次 开发 Vba 计算 压力管壁厚计算 dvb Module1 YLGBHJS ID GTBHJS 缸筒壁厚计算 C C vbarun F 编程 作品 CAD 二次开发 二次开 发 Vba 计算 缸筒壁厚计算 dvb Module1 GTBHJS ID Bearing 轴承型号大全 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 AcadVBA dvb ModBearing Bearing ID LiuLiang 油缸流量计算 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 流量计算 dvb Module1 LiuLiang ID YYZHDJGL 液压站电机功率计算 C C vbarun F 编程 作品 CAD 二次开发 二次 开发 Vba 计算 AcadVBA dvb modYYZHDJGL YYZHDJGL id GearMatching CAD 系统设置 ID MButton 鼠标中键控制 ID MButtonPan 鼠标中键平移 C C setvar mbuttonpan 1 ID MButtonMenu 设置正角度的方向 ID anticlockwise 逆时针 C C setvar ANGDIR 0 ID deasil 隐含边延伸模式 ID extend 延伸 E C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 AcadVBA dvb ModExtendMode extend ID NoExtend 显示文件对话框 ID filediaON 显示 C C setvar filedia 1 ID filediaOFF 设置修剪和延伸的当前 投影 模式 ID PROJMODE0 真三维模式 无投影 C C setvar PROJMODE 0 ID PROJMODE1 投影到当前 UCS 的 XY 平面上 C C setvar PROJMODE 1 ID PROJMODE2 预览图像是否随图形一起保存 ID RASTERPREVIEWOFF 不创建预览图像 C C setvar RASTERPREVIEW 0 ID RASTERPREVIEWON 寄出错误报告到 ID REPORTERRORON 显示 C C setvar REPORTERROR 1 ID REPORTERROROFF 双击鼠标编辑对象 ID PICKSTYLE OK 使用 C C setvar PICKSTYLE 0 ID PICKSTYLE NO 不使用 C C setvar PICKSTYLE 1 ID ANGBASE 基准角置零 图案为Ansi31 C C vbarun F 编程 作品 CAD二次开发 二次开发 Vba 计算 AcadVBA dvb modCADSysVariant AngBaseIs0 ID ZOOMFACTOR 鼠标辊抡缩放速度 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 鼠标辊抡缩放速度 dvb Module1 SFSD ID HPNAME 设置默认填充图案为 ANSI31 C C setvar HPNAME ansi31 ID CELTSCALE 设置当前对象的线型比例因子为 1 C C setvar CELTSCALE 1 ID QLHCHBC Windows 系统工具 ID CALC 计算器 CTRL SHIFT ALT Z C C vbarun F 编程 作品 CAD 二 次开发 二次开发 Vba 计算 winsystools dvb Module1 calc ID Mspaint 画笔 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 winsystools dvb Module1 mspaint ID CALC1 实用计算器 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 winsystools dvb Module1 calc1 ID ChangeWPaper 电话表 ID FDTel 公司电话表 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 AcadVBA dvb modTel FDTel ID ZHGTel 菜单 ID Update CAD2002 菜单更新 C C vbarun F 编程 作品 CAD 二次开发 二次开 发 Vba 计算 UpdateFDMenu dvb Module1 Update02menu ID Update04 这句是在 CAD 中的菜单组名 POP1 这行为弹出菜单标识 pop 加上数字 至于此部分的说明如下 MENUGROUP 菜单组名 BUTTONSn 定点设备按钮菜单 AUXn 系统定点设备菜单 POPn 下拉菜单和快捷菜单 TOOLBARS 工具栏定义 IMAGE 图像控件菜单 SCREEN 屏幕菜单 TABLETn 数字化仪菜单 HELPSTRINGS 当亮显下拉菜单或快捷菜单项时 或者当光标位于工具栏按钮上时 显 示状态栏中的文字 ACCELERATORS 快捷键 或加速键 定义 下面这句就开始定义菜单上的项目了 ID COMPUTE 富地 2004 C 其中前面的 ID COMPUTE 就是这个菜单项的唯一的标识 方括号内的就是菜单上显示的内 容了 括号内的那个连字符加上一个字母 C 它在菜单上会显示 C 下面带一个下划线 这 个就是我们定义的热键 当屏幕显示此菜单时我们按 Alt C 键时 就相当于我们用鼠标点击 此菜单 在这行的后面我们什么也没加 是因为这是菜单的第一个项 因此不需要它做什么 下一行的后面的这个 C C vbarun F 编程 作品 CAD 二次开发 二次开发 Vba 计算 通 信 dvb Module1 TongXin 是我们点击此菜单项所执行的动作 前面的 C C 是相当于按了两 次 Esc 键 主要是为了取消前一个正在运行的命令 下面的 vbarun 是运行 VBA 程序的命令 再后面的的就是这个 VBA 宏文件的路径和名称了 如果将此宏文件的路径加到 CAD 支持 文件的搜索路径内 就可以去掉前面的路径了 要注意的是在后面的行中的方括号内有 和鼠标中键控制 ID MButtonPan 鼠标中键平移 C C setvar mbuttonpan 1 ID MButtonMenu 显示文件对话框 ID filediaON 显示 C C setvar filedia 1 ID filediaOFF 不显示 C C setvar filedia 0 ID ZOOMFACTOR 鼠标辊抡缩放速度 C C vbarun c Tests dvb Module1 SFSD ID CALC 计算器 C C vbarun C Tests dvb Module1 calc ID CIRCLE 画圆 C C vbarun C Tests dvb Module1 circles ID MENUUPDATE 菜单更新 C C vbarun C Tests dvb Module1 updatemenus TOOLBARS HELPSTRINGS ID CALC 打开计算器 ID MButtonPan 当按下鼠标中键平移视口 ID MButtonMenu 当按下鼠标中键弹出菜单 ID filediaON 当对文件进行操作时打显示件对话框 ID filediaOFF 当对文件进行操作时显示文件对话框 ID ZOOMFACTOR 设置鼠标辊轮的缩放速度 ID CIRCLE 画一个圆 ID MENUUPDATE 从菜单文件更新此菜单 VBA 源程序文件名为 Tests dvb 放在 C 盘根目录 里面添加一个模块 名为 Module1 两个窗 体分别名为 frmCircle 和 frmMouse Module1 里面的代码为下面内容 Option Explicit Dim MnuGroup AsAcadMenuGroup Public Enum enuLineType ltContinuous 0 ltCenter 1 ltDASHED 2 ltPHANTOM 3 End Enum Public Sub calc Shell calc exe vbNormalFocus End Sub Public Sub SFSD frmMouse Show End Sub Public Sub Circles frmCircle Show End Sub Public Sub UpdateMenu End Sub 判断图层是否存在 Public Function LayerExist ByVal strLayerName As String As Boolean Dim objLayer As AcadLayer For Each objLayer In ThisDrawing Layers If objLayer Name strLayerName Then LayerExist True Exit For End If Next End Function 添加图层 Public Function AddLayers ByVal strLayerName As String LineType As enuLineType lColor As ACAD COLOR lineWeightAs AcLineWeight AsAcadLayer Dim objLayer As AcadLayer On Error GoTo LineError Set objLayer ThisDrawing Layers Add strLayerName If LineTypeExist LineType False Then ThisDrawing Linetypes Load GetLineTypeString LineType acadiso lin 添加线型 End If objLayer LineType GetLineTypeString LineType objLayer color lColor objLayer lineWeight lineWeight Set AddLayers objLayer Exit Function LineError MsgBox Err Number Chr 13 Err Description 16 End Function 获得图层 Public Function GetLayer ByVal strLayerName As String As AcadLayer Dim objLayer As AcadLayer For Each objLayer In ThisDrawing Layers If objLayer Name strLayerName Then Set GetLayer objLayer Exit For End If Next End Function 判断线型是否存在 Private Function LineTypeExist ByVal LineTypeName As enuLineType As Boolean Dim objLineType As AcadLineType For Each objLineType In ThisDrawing Linetypes If objLineType Name GetLineTypeString LineTypeName Then LineTypeExist True Exit For End If Next End Function Private Function GetLineTypeString ByVal LineTypeAs 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 Select End Function Public Sub UpdateMenus On Error Resume Next Application MenuGroups Item Test Unload Application MenuGroups Load c Test mns Set MnuGroup Application MenuGroups Item Test MnuGroup Menus InsertMenuInMenuBar Test T Application MenuBar Count 1 End Sub frmCircle 的窗体内容为 窗体内的代码为 Option Explicit Dim dblPoints 2 As Double dblR As Double Private Sub cmdOK Click Dim objCircle As AcadCircle Dim objLayer As AcadLayer objOldLayer As AcadLayer Dim dblStart 2 As Double dblEnd 2 As Double dblExtend As Double dblPoints 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 If Set 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 If ThisDrawing ActiveLayer objLayer 设置中心线层为当前层 dblStart 0 dblPoints 0 dblR dblExtend dblStart 1 dblPoints 1 dblStart 2 dblPoints 2 dblEnd 0 dblPoints 0 dblR dblExtend dblEnd 1 dblPoints 1 dblEnd 2 dblPoints 2 ThisDrawing ModelSpace AddLine dblStart dblEnd dblStart 0 dblPoints 0 dblStart 1 dblPoints 1 dblR dblExtend