大家知道什么是宏嗎？說白它就是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