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

大家知道什么是宏吗？
说白它就是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 [<-渐开线齿轮...]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/渐开线.dvb!jkx.jkx
ID_DesignTools [->设计工具]
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 [<-齿轮幅齿数匹配...]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!modGearMatching.GearMatching
ID_CADSysOption [->CAD系统设置]
ID_MButton [->鼠标中键控制]
ID_MButtonPan [鼠标中键平移]^C^C_setvar mbuttonpan 1
ID_MButtonMenu [<-鼠标中键菜单]^C^C_setvar mbuttonpan 0
ID_ANGDIR [->设置正角度的方向]
ID_anticlockwise [逆时针]^C^C_setvar ANGDIR 0
ID_deasil [<-顺时针]^C^C_setvar ANGDIR 1
ID_extendMode [->隐含边延伸模式]
ID_extend [延伸(&E)]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba 计算/AcadVBA.dvb!ModExtendMode.extend
ID_NoExtend [<-不延伸(&N)]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!ModExtendmode.noextend
ID_filedia [->显示文件对话框]
ID_filediaON [显示]^C^C_setvar filedia 1
ID_filediaOFF [<-不显示]^C^C_setvar filedia 0
ID_PROJMODE [->设置修剪和延伸的当前“投影”模式]
ID_PROJMODE0 [真三维模式(无投影)]^C^C_setvar PROJMODE 0
ID_PROJMODE1 [投影到当前UCS的XY平面上]^C^C_setvar PROJMODE 1
ID_PROJMODE2 [<-投影到当前视图平面]^C^C_setvar PROJMODE 2
ID_RASTERPREVIEW [->预览图像是否随图形一起保存]
ID_RASTERPREVIEWOFF [不创建预览图像]^C^C_setvar RASTERPREVIEW 0
ID_RASTERPREVIEWON [<-创建预览图像]^C^C_setvar RASTERPREVIEW 1 ID_REPORTERROR [->寄出错误报告到]
ID_REPORTERRORON [显示]^C^C_setvar REPORTERROR 1
ID_REPORTERROROFF [<-不显示]^C^C_setvar REPORTERROR 0
ID_PICKSTYLE [->双击鼠标编辑对象]
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 [<-清理、核查、缩放并保存CTRL+ALT+Q]^C^C-purge a * n _audit y zoom e qsave
ID_WinOption [->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 [<-更换系统桌面...]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/WallPaperChanger.dvb!Module1.WallPaperChanger
ID_Tel [->电话表]
ID_FDTel [公司电话表...]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!modTel.FDTel
ID_ZHGTel [<-重工电话表...]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/AcadVBA.dvb!modTel.ZHGTel
ID_Menu [->菜单]
ID_Update [CAD2002菜单更新]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/UpdateFDMenu.dvb!Module1.Update02menu
ID_Update04 [<-CAD2004菜单更新]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/UpdateFDMenu.dvb!Module1.Update04menu
***TOOLBARS
**TOOLBARWYP
ID_ToolbarWYP_0 [_Toolbar("ToolbarWyp", _Top, _Show, 0, 2, 1)]
ID_OsnapCent [_Button("捕捉到圆心", "RCDATA_16_OSNCEN", "RCDATA_16_OSNCEN")]_cen
ID_OsnapTang [_Button("捕捉到切点", "RCDA TA_16_OSNTAN", "RCDATA_16_OSNTAN")]_tan
ID_PCCAD_PCZXX_0 [_Button("中心线ZX", "//Ca.bmp", "ZXX.bmp")]^P^C^CPC_zXX T
[--]
ID_Circle2pt_0 [_Button("圆两点", "RCDATA_16_CIR2PT", "RCDATA_16_CIR2PT")]^C^C_circle _2p
ID_3dpoly_0 [_Button("三维多段线", "RCDATA_16_3DPOL Y", "RCDATA_16_3DPOL Y")]^C^C_3dpoly
ID_Hatchedit_0 [_Button("编辑图案填充", "RCDATA_16_HATEDI", "RCDATA_16_HATEDI")]^C^C_hatchedit
ID_Region_0 [_Button("面域", "RCDA TA_16_REGION", "RCDATA_16_REGION")]^C^C_region
[--]
ID_Sphere_0 [_Button("球体", "RCDATA_16_SPHERE", "RCDATA_16_SPHERE")]^C^C_sphere
ID_Extrude_0 [_Button("拉伸", "RCDATA_16_EXTRUD", "RCDATA_16_EXTRUD")]^C^C_extrude
ID_Revolve_0 [_Button("旋转", "RCDA TA_16_REVOLV", "RCDATA_16_REVOLV")]^C^C_revolve
ID_Slice_0 [_Button("剖切", "RCDA TA_16_SLICE", "RCDATA_16_SLICE")]^C^C_slice [--]
ID_Union_0 [_Button("并集", "RCDATA_16_UNION", "RCDATA_16_UNION")]^C^C_union
ID_Subtract_0 [_Button("差集", "RCDATA_16_SUBTRA", "RCDATA_16_SUBTRA")]^C^C_subtract
ID_Intersect_0 [_Button("交集", "RCDA TA_16_INTERS", "RCDATA_16_INTERS")]^C^C_intersect
ID_FaceExtru_0 [_Button("拉伸面", "RCDA TA_16_EXTRUD", "RCDATA_16_EXTRUD")]^C^C_solidedit _face _extrude
ID_Shell_0 [_Button("抽壳", "RCDATA_16_SHELL", "RCDATA_16_SHELL")]^C^C_solidedit _body _shell
[--]
ID_Massprop_0 [_Button("面域/质量特性", "RCDATA_16_MASSPR", "RCDATA_16_MASSPR")]^C^C_massprop
ID_UBBulk_0 [_Button("体积", "ICON.bmp", "ICON_16_BLANK")]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/体积.dvb!Module1.bulk
[--]
ID_2doptim_0 [_Button("二维线框", "RCDA TA_16_2DOPTIM", "RCDATA_16_2DOPTIM")]$M=$(if,$(and,$(eq,$(getvar,tilemode),0),$(eq,$(getvar,cvport),1)),^ C^C_shademode,^C^C_shademode _2)
ID_Wireframe_0 [_Button("三维线框", "RCDATA_16_WIREFRAME", "RCDATA_16_WIREFRAME")]$M=$(if,$(and,$(eq,$(getvar,tilemode),0),$(eq,$(getvar,cvport),1 )),^C^C_shademode,^C^C_shademode _3)
ID_Hidden_0 [_Button("消隐", "RCDATA_16_HIDDEN", "RCDATA_16_HIDDEN")]$M=$(if,$(and,$(eq,$(getvar,tilemode),0),$(eq,$(getvar,cvport),1)),^C ^C_shademode,^C^C_shademode _h)
ID_Gouraud_0 [_Button("体着色", "RCDATA_16_GOURAUD",
"RCDATA_16_GOURAUD")]$M=$(if,$(and,$(eq,$(getvar,tilemode),0),$(eq,$(getvar,cvport),1)), ^C^C_shademode,^C^C_shademode _g)
ID_UBZIs0 [_Button("User Defined Button", "ICON1286.bmp", "ICON_16_BLANK")]^C^C-vbarun F:/编程/作品/CAD二次开发/二次开发/Vba计算/Z轴为0.dvb!Module1.SetZIs0
[--]
ID_Dimlinear [_Button("线性标注", "RCDATA_16_DIMLIN", "RCDATA_16_DIMLIN")]^C^C_dimlinear
ID_DimUpdate [_Button("标注更新", "RCDATA_16_DIMUPD", "RCDATA_16_DIMUPD")]^C^C_-dimstyle _apply
[--]
ID_TbViewpoi_0 [_Flyout("视图", RCDA TA_16_DDVIEW, RCDATA_16_DDVIEW, _OtherIcon, ACAD.TB_VIEWPOINT)]
ID_ZoomExten_0 [_Button("范围缩放", "RCDATA_16_ZOOEXT", "RCDATA_16_ZOOEXT")]'_zoom _e
[--]
ID_UserButton_1 [_Button("清理、核查、缩放并保存", "RCDA0986.bmp", "RCDATA_16_BLANK")]^C^C-purge a * n _audit y zoom e qsave
[--]
ID_3darray_0 [_Button("三维阵列", "RCDA9985.bmp", "RCDATA_16_BLANK")]^C^C_3darray
ID_Mirror3d_0 [_Button("三维镜像", "RCDA3513.bmp", "RCDATA_16_BLANK")]^C^C_mirror3d
ID_Rotate3d_0 [_Button("三维旋转", "RCDA5650.bmp", "RCDATA_16_BLANK")]^C^C_rotate3d
***ACCELERATORS
ID_BULK1 [CONTROL+SHIFT+"Z"]
ID_PCCAD_PCZXX_0 [CONTROL+ALT+TOOLBAR+"Z"]
ID_BKJQJS [CONTROL+SHIFT+"S"]
ID_CALC [CONTROL+SHIFT+ALT+"Z"]
ID_UserButton_1 [CONTROL+SHIFT+TOOLBAR+"X"]
ID_QLHCHBC [CONTROL+ALT+"Q"]
ID_TongXin [CONTROL+SHIFT+"A"]
***HELPSTRINGS
ID_UPDA TE [更新计算菜单]
ID_GTBHJS [缸筒管壁厚计算...]
ID_REVOLVE_0 [绕轴旋转二维对象以创建实体: REVOLVE]
ID_SHELL_0 [以指定的厚度在实体对象上创建中空的薄壁: SOLIDEDIT]
ID_BULK1 [计算基本几何体的体积]
ID_SLICE_0 [用平面剖切一组实体: SLICE]
ID_SUBTRACT_0 [用差集创建组合面域或实体: SUBTRACT]
ID_DIMLINEAR [创建线性标注: DIMLINEAR]
ID_UBZIS0 [将多义线各节点Z轴设为零]
ID_SPHERE_0 [创建三维实心球体: SPHERE]
ID_JKX [渐开线...]
ID_HA TCHEDIT_0 [修改现有的图案填充对象: HA TCHEDIT]
ID_UBBULK_0 [计算基本几何体的体积]
ID_FACEEXTRU_0 [按指定高度或沿路径拉伸实体对象的选定面: SOLIDEDIT]
ID_CIRCLE2PT_0 [用直径的两个端点创建圆: CIRCLE]
ID_REGION_0 [将包含封闭区域的对象转换为面域对象: REGION]
ID_ZISZERO [将多义线各节点Z轴设为零]
ID_HIDDEN_0 [将视口设置为隐藏线: SHADEMODE]
ID_INTERSECT_0 [从实体或面域的交集创建组合实体或面域: INTERSECT]
ID_DIMUPDATE [更新标注的样式: DIMSTYLE]
ID_NDJS [挠度计算... CTRL+SHIFT+C]
ID_2DOPTIM_0 [将视口设置为二维线框: SHADEMODE]
ID_OSNAPCENT [捕捉到圆弧、圆、椭圆或椭圆弧的中心点: CEN]
ID_OSNAPTANG [捕捉到圆弧、圆、椭圆、椭圆弧或样条曲线的切点: TAN]
ID_MIRROR3D_0 [创建对象相对于某一平面的镜像图像副本: MIRROR3D]
ID_3DARRAY_0 [创建三维阵列: 3DARRAY]
ID_LIANLUN [链轮参数计算...]
ID_MASSPROP_0 [计算并显示面域或实体的质量特性: MASSPROP]
ID_ZOOMEXTEN_0 [显示图形范围: ZOOM]
ID_LUOXUANXIAN [三维螺旋线...]
ID_YGXCKDGS [圆管型材宽度估算...]
ID_BKJQJS [圆管型材宽度精算... CTRL+SHIFT+S]
ID_USERBUTTON_0 [用户定义的按钮]
ID_WIREFRAME_0 [将视口设置为三维线框: SHADEMODE 3]
ID_YLGBHJS [压力管壁厚计算...]
ID_EXTRUDE_0 [通过拉伸现有二维对象来创建三维实体: EXTRUDE]
ID_USERBUTTON_1 [清理、核查、缩放并保存]
ID_ROTA TE3D_0 [绕三维轴转动对象: ROTATE3D]
ID_CALC1 [实用计算器...]
ID_3DPOL Y_0 [在三维空间中创建多段线: 3DPOL Y]
ID_UNION_0 [用并集创建组合面域或实体: UNION]
ID_TBVIEWPOI_0 [“视点”工具栏]
ID_CALC [计算器... CTRL+SHIFT+ALT+Z]
ID_GOURAUD_0 [将视口设置为体着色: SHADEMODE]
ID_WorkAffiliation [打开工作联系单...]
//
// AutoCAD 菜单文件结尾- C:\Documents and Settings\wuyp\Local Settings\Application Data\Autodesk\AutoCAD 2004\R16.0\chs\FD04Menu.mns
//
其中前面加双斜杠的先不用管它
***MENUGROUP=wyp ->这句是在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支持文件的搜索路径内，就可以去掉前面的路径了。

要注意的是在后面的行中的方括号内有->和<-符号，而且在右箭头的后面还没加代码，这是因为当CAD加载右箭头它解析为后面的项目为下一级的子菜单项。

当出现左箭头时为结束子菜单项，返回上一级菜单
下面的***ACCELERATORS定义快捷键的条目的前端的ID部分一定要和上边定义菜单部分的ID一样，这样快捷键才起作用
下面的***HELPSTRINGS定义当鼠标移到菜单项上面时在CAD的左下角的提示栏内所显示的帮助信息，此部分的ID也要和菜单项的对应
有人又要问了中间的工具条的部分怎么没有说呢？
其实工具条我们可以在CAD里面做好后再用VBA将其导出到菜单文件，这样做起来也比较容易。

做工具条
第一步右击工具条，点自定义
第二步选择菜单组，填工具条名
第三步选择命令页，分类框内选择用户自定义，将右边的用户自定义按钮托到工具条上
单击工具条上的用户自定义按钮，会自动转到按钮特性页面，选择图标、输入名称、说明和
下面的宏保存
在VBA中可用以下命令将现有菜单保存到文件中
Application.MenuGroups.Item(1).SaveAs "c:\Test", acMenuFileSource
用以下代码将菜单文件加载到CAD中
Dim mnuGroup As AcadMenuGroup
Application.MenuGroups.Load "C:\Test.mnc"
Set mnuGroup = Application.MenuGroups.Item("菜单组名")
mnuGroup.Menus.InsertMenuInMenuBar "Test(&T)", ""
Application.MenuGroups.Item(1).SaveAs "c:\Test", acMenuFileSource
这里括号内的数字为菜单组集合内的项目的索引，我的这里一共有5个索引是从0到4
您也可以遍历这个集合，获得菜单组的名称进行指定的操作
Set mnuGroup = Application.MenuGroups.Item("菜单组名")
mnuGroup.Menus.InsertMenuInMenuBar "Test(&T)", ""
这里的菜单组名和下边的Test(&T)必需和菜单文件里是一一对应的
菜单文件Test.mns的内容如下：
***MENUGROUP=Test
***POP1
ID_TEST [Test(&T)]
ID_MButton [->鼠标中键控制]
ID_MButtonPan [鼠标中键平移]^C^C_setvar mbuttonpan 1
ID_MButtonMenu [<-鼠标中键菜单]^C^C_setvar mbuttonpan 0
ID_filedia [->显示文件对话框]
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 As AcadMenuGroup
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 yers
If = 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, lineWeight As AcLineWeight) As AcadLayer
Dim objLayer As AcadLayer
On Error GoTo LineError
Set objLayer = yers.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 yers
If = 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 = GetLineTypeString(LineTypeName) Then
LineTypeExist = True
Exit For
End If
Next
End Function
Private 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 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
dblStart(2) = dblPoints(2)
dblEnd(0) = dblPoints(0)
dblEnd(1) = dblPoints(1) - dblR - dblExtend
dblEnd(2) = dblPoints(2)
ThisDrawing.ModelSpace.AddLine dblStart, dblEnd
ThisDrawing.ActiveLayer = objOldLayer '还原之前的层
Unload Me
End Sub
'在模型空间选择圆心座标点
Private Sub cmdSelect_Click()
Dim varPoint As Variant
On Error Resume Next
Me.Hide
varPoint = ThisDrawing.Utility.GetPoint(, "请选择点：")
txtX.Text = varPoint(0)
txtY.Text = varPoint(1)
txtZ.Text = varPoint(2)
Me.Show
End Sub
Private Sub TxtExtend_Change()
End Sub
'frmMouse的窗体内容为
'窗体内的代码为：
Private Sub cmdOK_Click()
Dim sysVarName As String, sysVarData As V ariant
sysVarName = "ZOOMFACTOR"
sysVarData = Int(Val(TextBox1.Text))
ThisDrawing.SetVariable sysVarName, sysVarData
Unload Me
End Sub
好了，我的程序部分已经做完了，下面要把菜单加入CAD了
第一步打开CAD输入命令menuload回车
第二步点击浏览找到我们之前做好的放在C盘根目录的test.mnc文件，并点加载第三步点菜单栏选项卡，将我们的菜单加到想要的位置。