AutoVBA创建自定义下拉菜单

使用VBA向AutoCAD中添加新的菜单，涉及以下操作，创建新的菜单，使用Add方法向PopMenus集合添加新的PopMenu对象，向菜单中添加新的菜单项；使用AddMenuItem方法；向菜单中添加分隔符，使用AddSeperator方法；通过VBA为菜单项指定加速键，使用给定菜单项的Label属性；添加级联子菜单，使用AddSubmenu方法创建子菜单；要删除菜单中的菜单项使用该菜单项的Delete方法。

Sub addasubmenu()
    Dim currmenugroup As AcadMenuGroup
    Set currmenugroup = ThisDrawing.Application.MenuGroups.Item(0)
    Dim newmenu As AcadPopupMenu
    Set newmenu = currmenugroup.Menus.Add("mmymen" & Chr(Asc("&")) & "u")
    Dim macro As String
    macro = Chr(vbKeyEscape) + Chr(vbKeyEscape)
    Dim menuitemopen As AcadPopupMenuItem
    Set menuitemopen = newmenu.AddMenuItem(newmenu.Count + 1, Chr(Asc("&")) & "openfile", macro & "_open")
    menuitemopen.HelpString = "打开图形文件"
    Dim menuitemclose As AcadPopupMenuItem
    Set menuitemclose = newmenu.AddMenuItem(newmenu.Count + 1, Chr(Asc("&")) & "CloseFile", macro & "_close")
    menuitemclose.HelpString = "关闭图形文件"
    Dim menuitemsepatator As AcadPopupMenuItem
    Set menuitemseparator = newmenu.AddSeparator("")
    Dim menuitemdraw As AcadPopupMenu
    Set menuitemdraw = newmenu.addsubmenu(newmenu.Count + 1, Chr(Asc("&")) & "Draw")
    Dim submenuitemline As AcadPopupMenuItem
    Set submenuitemline = menuitemdraw.AddMenuItem(menuitemdraw.Count + 1, Chr(Asc("&")) & "line", macro & "_line")
    Dim submenuitemarc As AcadPopupMenuItem
    Set submenuitemarc = menuitemdraw.AddMenuItem(menuitemdraw, Count + 1, Chr(Asc("&")) & "Arc", macro & "_arc")
    Dim submenuitemcircle As AcadPopupMenuItem
    Set submenuitemcircle = menuitemdraw.AddMenuItem(menuitemdraw.Count + 1, Chr(Asc("&")) & "Circle", macro & "-vbarun" + Chr(32) + "thisdrawing.drawcircle" + Chr(32))
    Dim menuitemdim As AcadPopupMenu
    Set menuitemdim = newmenu.addsubmenu(newmenu.Count + 1, "dimensio" & Chr(Asc("&")) & "n")
    Dim submenuitemaligned As AcadPopupMenuItem
    Set submenuitem = menuitemdim.AddMenuItem(menuitemdim.Count + 1, "dimali" & Chr(Asc("&")) & "gned", macro & "_dimaligned")
    Dim submenuitemlinear As AcadPopupMenuItem
    Set submenuitemlinear = menuitemdim.AddMenuItem(menuitemdim.Count + 1, "Dim" & Chr(Asc("&")) & "Linear", macro & "_dimLinear")
    Dim submenuitemordinate As AcadPopupMenuItem
    Set submenuitemordinate = menuitemdim.AddMenuItem(menuitemdim.Count + 1, "Dim" & Chr(Asc("&")) & "ordinate", macro & "_dimordinate")
    newmenu.insertmenubar (ThisDrawing.Application.MenuBar.Count + 1)
    Dim scmenu As AcadPopupMenu
    Dim element As AcadPopupMenu
    For Each element In currmenugroup.Menus
        If element.ShortcutMenu – True Then
            Set scmenu = element
        End If
    Next element
    Dim scmenuitem As AcadPopupMenuItem
    Set scmenu = scmenu.AddMenuItem("", "测量距离", macro & "_dist")
End Sub
Sub drawcircle()
    Dim ptcen(0 To 2) As Double
    ptcen(0) = 200
    ptcen(1) = 200
    ptcen(2) = 0
    ThisDrawing.ModelSpace.AddCircle ptcen, 60
    ZoomExtents
End Sub

按F5键运行程序，即可看到新添加的菜单。