[分享] 可任意扩展的菜单及功能代码 [复制链接]

.pcb{margin-right:0} '*************************************************'
'*    可任意扩展的菜单及功能代码         *'
'*       -------------------------------             *'
'*               日期：2009-10-1                 *'
'*************************************************'

Sub AddCustomMenu() '建立自定义菜单主调程序
   On Error Resume Next
      Application.ScreenUpdating = False
      For i = Application.MenuBars(xlWorksheet).Menus.Count To 1 Step -1
          Application.MenuBars(xlWorksheet).Menus.Item(i).Delete
     Next i
     With Application
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
        .CommandBars("Stop Recording").Visible = False
        .CommandBars("toolbar list").Enabled = False
        .CommandBars.DisableAskAQuestionDropdown = True
        .DisplayFormulaBar = False
    End With
    Dim cmb As CommandBarControl

    Set cmb = AddCustomCommandBarPopup("主菜单1(&字母)") '设置主菜单
   
    AddCustomCommandBarItem cmb, "下级菜单1(&字母)", "宏1", False, True, 0, "" '设置下级菜单并调用宏1
    Set cmb = Application.CommandBars("Worksheet Menu Bar").Controls("主菜单1(&字母)")
    AddCustomCommandBarItem cmb, "下级菜单1(&字母)", "", False, True, 0, "" '与"下级菜单1(&字母)"菜单同级


    Set cmb = AddCustomCommandBarPopup("主菜单2(&字母)") '设置主菜单
   
    AddCustomCommandBarItem cmb, "下级菜单2", "宏2", False, True, 0, "" '设置下级菜单并调用宏2

   '可任意扩展菜单项

  '……
End Sub

Function AddCustomCommandBarPopup(Caption As String) As CommandBarControl    '添加主菜单项
   Dim cmb As CommandBarControl
    Set cmb = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
    cmb.Caption = Caption
    cmb.Visible = True
    Set AddCustomCommandBarPopup = cmb
End Function

Sub AddCustomCommandBarItem(cmbc As CommandBarControl, _
                            Caption As String, Macro As String, NewGroup As Boolean, Enable As Boolean, FId As Integer, ShortT As String)    '添加菜单选项
    Dim cbb As CommandBarButton
    Set cbb = cmbc.Controls.Add(msoControlButton)
    cbb.Caption = Caption
    If FId > 0 Then cbb.FaceId = FId
    If ShortT <> "" Then cbb.ShortcutText = ShortT
    cbb.OnAction = Macro
    cbb.BeginGroup = NewGroup
    cbb.Enabled = Enable
End Sub

Function AddCustomCommandBarPopup2(cmbc As CommandBarControl, Caption As String) As CommandBarControl   '添加子菜单项
    Dim cmb As CommandBarControl
    Set cmb = cmbc.Controls.Add(msoControlPopup)
    cmb.Caption = Caption
    cmb.Visible = True
    Set AddCustomCommandBarPopup2 = cmb
End Function