清风明月名字 发表于 2014-1-14 13:16:55

求高手纠正宏工程里面的创建菜单的自定义函数

本帖最后由 清风明月名字 于 2014-1-14 13:20 编辑


上面宏工程的代码，我的总体设想是，我每次打开一个窗体，它就会帮我创建一个按钮，这样就避免了我再去查找启动这个窗体的宏了，运行菜单就行了。所以按钮只能运行一次创建一个。
我写了一套代码，是创建多级菜单的。
我碰到的问题是：
如果初次创建，三级菜单都会被成功创建。第二次运行的时候要在上次创建的菜单中添加按钮，则失败了。我跟踪代码发现，“菜单二”就无法获得对象，也就无法创建第二个按钮。

希望有高手能帮我解决，纠正里面的创建菜单的自定义函数。
下面是宏工程中的自定义函数之一：


Function 创建三级菜单按钮(一级菜单名, 二级菜单名, 三级菜单名, VBA或LSP, 按钮标题, 命令)
      On Error Resume Next
      Dim macro As String
      macro = Chr(vbKeyEscape) + Chr(vbKeyEscape) '这是在向命令行发送命令时需要的前缀。

      Dim currMenuGroup As AcadMenuGroup
      Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

      '下面是创建菜单“工”
      Dim 菜单一 As AcadPopupMenu
      Set 菜单一 = currMenuGroup.Menus.Add(一级菜单名 & Chr(Asc("&"))) '这是说在没有时创建菜单“小多”
      Set 菜单一 = currMenuGroup.Menus(一级菜单名 & Chr(Asc("&"))) '这是说在已有菜单“小多”时就让它赋给变量“newMenu”

      Dim 菜单二 As AcadPopupMenu
      Set 菜单二 = 菜单一.AddSubMenu(菜单一.Count + 1, 二级菜单名 & Chr(Asc("&")))
      Set 菜单二 = 菜单一.Item(二级菜单名 & Chr(Asc("&")))

      Dim 菜单三 As AcadPopupMenu
      Set 菜单三 = 菜单二.AddSubMenu(菜单二.Count + 1, 三级菜单名 & Chr(Asc("&")))
      Set 菜单三 = 菜单二.Items(三级菜单名 & Chr(Asc("&")))

      Dim subMenuItemPoint As AcadPopupMenuItem
      Set subMenuItemPoint = 菜单三.Item(按钮标题)
      subMenuItemPoint.Delete '是如果存在以程序文件简单名为名的按钮，则删除它，再创建，以免同名而内容不同的错误

      If VBA或LSP = "LSP" Then
            '创建程序文件简单名为名的按钮,单击按钮时发出"-VBARUN XIANSHISHIYIANDAIMAYONGCHUANGTI "命令
            Set subMenuItemPoint = 菜单三.AddMenuItem(菜单三.Count + 1, Chr(Asc("&")) & 按钮标题, macro & 命令 & " ")
      Else
             Set subMenuItemPoint = 菜单三.AddMenuItem(菜单三.Count + 1, Chr(Asc("&")) & 按钮标题, macro & "-VBARUN " & 命令 & " ")
      End If

菜单一.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)

End Function





efan2000 发表于 2014-1-14 13:16:56

创建三个通用函数，简化操作。
' AddMenu 在菜单组中创建菜单，如果菜单已经存在，直接返回
' mg 菜单组
' name 要创建的菜单名称
Function AddMenu(ByVal mg As AcadMenuGroup, ByVal name As String) As AcadPopupMenu
    Dim pm As AcadPopupMenu
    Dim b As Boolean
    b = False
    Dim i As Integer
    For i = 0 To mg.Menus.Count - 1
      If mg.Menus(i).name = name Then
            Set pm = mg.Menus(i)
            b = True
            Exit For
      End If
    Next
    If b = False Then
      Set pm = mg.Menus.Add(name)
    End If
    Set AddMenu = pm
End Function

' AddSubMenu 在菜单、子菜单中创建子菜单，如果子菜单已经存在，直接返回
' parentpm 父级菜单
' caption 要创建的子菜单标题
Function AddSubMenu(ByVal parentpm As AcadPopupMenu, ByVal caption As String) As AcadPopupMenu
    Dim pm As AcadPopupMenu
    Dim b As Boolean
    b = False
    Dim i As Integer
    For i = 0 To parentpm.Count - 1
      If parentpm(i).caption = caption Then
            Set pm = parentpm(i).SubMenu
            b = True
            Exit For
      End If
    Next
    If b = False Then
      Set pm = parentpm.AddSubMenu(parentpm.Count + 1, caption)
    End If
    Set AddSubMenu = pm
End Function

' AddMenuItem 在菜单、子菜单中创建菜单项，如果delete为真，先删除菜单项再创建。如果delete为假，菜单项已经存在时直接返回
' parentpm 父级菜单
' label 要创建的菜单项标签
' macro 要创建的菜单项宏
' delete 是否先删除菜单项
Function AddMenuItem(ByVal parentpm As AcadPopupMenu, ByVal label As String, ByVal macro As String, Optional ByVal delete As Boolean = True) As AcadPopupMenuItem
    Dim pmi As AcadPopupMenuItem
    Dim b As Boolean
    b = False
    Dim i As Integer
    For i = 0 To parentpm.Count - 1
      If parentpm(i).caption = label Then
            Set pmi = parentpm(i)
            If delete = True Then
                pmi.delete
                b = False
            Else
                b = True
            End If
            Exit For
      End If
    Next
    If b = False Then
      Set pmi = parentpm.AddMenuItem(parentpm.Count + 1, label, macro)
    End If
    Set AddMenuItem = pmi
End Function
最后过程：
Function 创建三级菜单按钮(一级菜单名, 二级菜单名, 三级菜单名, VBA或LSP, 按钮标题, 命令)
      'On Error Resume Next
      Dim macro As String
      macro = Chr(vbKeyEscape) + Chr(vbKeyEscape) '这是在向命令行发送命令时需要的前缀。

      Dim currMenuGroup As AcadMenuGroup
      Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

      '下面是创建菜单“工”
      Dim 菜单一 As AcadPopupMenu
      Set 菜单一 = AddMenu(currMenuGroup, 一级菜单名 & Chr(Asc("&")))   '这是说在没有时创建菜单“小多”
      
      Dim 菜单二 As AcadPopupMenu
      Set 菜单二 = AddSubMenu(菜单一, 二级菜单名 & Chr(Asc("&")))
      
      Dim 菜单三 As AcadPopupMenu
      Set 菜单三 = AddSubMenu(菜单二, 三级菜单名 & Chr(Asc("&")))
      
      Dim subMenuItemPoint As AcadPopupMenuItem
      If VBA或LSP = "LSP" Then
            '创建程序文件简单名为名的按钮,单击按钮时发出"-VBARUN XIANSHISHIYIANDAIMAYONGCHUANGTI "命令
            Set subMenuItemPoint = AddMenuItem(菜单三, Chr(Asc("&")) & 按钮标题, macro & 命令 & " ")
      Else
             Set subMenuItemPoint = AddMenuItem(菜单三, Chr(Asc("&")) & 按钮标题, macro & "-VBARUN " & 命令 & " ")
      End If
      
      Dim b As Boolean
      b = False
      Dim i As Integer
      For i = 0 To ThisDrawing.Application.MenuBar.Count - 1
            If ThisDrawing.Application.MenuBar(i).name = 一级菜单名 & Chr(Asc("&")) Then
                b = True
                Exit For
            End If
      Next
      If b = False Then
            菜单一.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
      End If
这样整个过程就清晰了，对于四级、五级菜单，只要重复调用AddSubMenu函数即可。

清风明月名字 发表于 2014-1-22 14:53:55

efan2000 发表于 2014-1-14 13:16 static/image/common/back.gif
创建三个通用函数，简化操作。

最后过程：


Set subMenuItemPoint = 菜单三.SubMenu(i) 上面这一句有错，“subMenuItemPoint”不能获得对象，也就无法删除。所以标题A（其命令为B）一旦创建，则第二次并不能将它改为命令为C，它的命令永远是B。望老师调试改正


efan2000 发表于 2014-1-22 16:39:07

本帖最后由 efan2000 于 2014-1-22 17:24 编辑

Set subMenuItemPoint = 菜单三.SubMenu(i)
如果菜单三是AcadPopupMenu对象，那么应该是Set subMenuItemPoint = 菜单三(i)
如果菜单三是AcadPopupMenuItem对象，那么应该是Set subMenuItemPoint = 菜单三.SubMenu(i)
页: [1]
查看完整版本: 求高手纠正宏工程里面的创建菜单的自定义函数