菜单文件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 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, lineWeight As AcLineWeight) As AcadLayer
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 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 Variant
sysVarName = "ZOOMFACTOR"
sysVarData = Int(Val(TextBox1.Text))
ThisDrawing.SetVariable sysVarName, sysVarData
Unload Me
End Sub
好了，我的程序部分已经做完了，下面要把菜单加入CAD了
