# 给cad添加自定义菜单

 

 1 Private Sub AddBar()
 2     Dim NewMenuItem As AcadPopupMenuItem
 3     Dim TheMacro As String
 4     Dim MI As Integer
 5     
 6     On Error Resume Next
 7     Dim currMenuGroup As AcadMenuGroup
 8     Set currMenuGroup = Application.MenuGroups.Item(0)
 9     'Create the new menu
10     Set NewMenu = currMenuGroup.Menus.Add("批量绘图")
11     If Err.Number Then
12         Err.Clear
13         For Each NewMenu In currMenuGroup.Menus
14             If NewMenu.Name = "批量绘图" Then Exit For
15         Next
16     End If
17     
18     'Add a menu item to the new menu
19     'Assign the macro string the VB equivalent of "ESC ESC _open "
20     'TheMacro = Chr(3) & Chr(3) & Chr(95) & "-vbarun ""GeoSection.dvb!DZPM.GeoSection""" & Chr(32)
21     TheMacro = Chr(3) & Chr(3) & Chr(95) & "-vbarun ""MainSub""" & Chr(32)
22     Set NewMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, "批量绘图", TheMacro)
23     If Err.Number Then Err.Clear
24     'Display the menu on the menu bar
25     NewMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
26     If Err.Number Then Err.Clear
27 End Sub

View Code

写几个事件驱动菜单显示

 

 1 Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
 2     If StrComp(Left$(CommandName, 3), "VBA", 1) <> 0 And UCase$(CommandName) <> "APPLOAD" Then Exit Sub
 3     If NewMenu Is Nothing Then AddBar
 4 End Sub
 5 
 6 Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
 7     If StrComp(Left$(CommandName, 3), "VBA", 1) <> 0 And UCase$(CommandName) <> "APPLOAD" Then Exit Sub
 8     If NewMenu Is Nothing Then AddBar
 9 End Sub
10 
11 Public Sub MainSub()
12     Dim frm As New UserForm1
13     Call UserForm1.Show
14 End Sub

View Code

 最终效果