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

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

本帖最后由清风明月名字于 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

创建三个通用函数，简化操作。

' 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

' 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

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

efan2000 发表于 2014-1-14 13:16
创建三个通用函数，简化操作。

最后过程：

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

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

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

Set subMenuItemPoint = 菜单三.SubMenu(i)
如果菜单三是AcadPopupMenu对象，那么应该是Set subMenuItemPoint = 菜单三(i)
如果菜单三是AcadPopupMenuItem对象，那么应该是Set subMenuItemPoint = 菜单三.SubMenu(i)

账号		自动登录	找回密码
密码			注册

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

最佳答案

相关帖子

点评

本帖子中包含更多资源

本帖子中包含更多资源

评分