Option Explicit
Const NA = "N/A"
'列偏移
Const TAG_OFFSET = 1
Const CAPTION_OFFSET = 2
Const TYPE_OFFSET = 3
Const ONACTION_OFFSET = 4
Const BEGINGROUP_OFFSET = 5
Const DESCRIPTION_OFFSET = 6
Sub BuildMenu()
Dim ws As Worksheet
Dim rg As Range
On Error GoTo ErrHandler
Set ws = ThisWorkbook.Worksheets("MenuBuilder")
'从第二行开始,因为第一行已经包含了列标题
Set rg = ws.Cells(2, 1)
Do Until IsEmpty(rg)
If rg.Value = NA Then
'新建顶级菜单项
AddTopLevelItem rg
Else
'现有控件的子菜单
AddSubItem rg
End If
'向下移一行
Set rg = rg.Offset(1, 0)
Loop
ExitPoint:
Set rg = Nothing
Set ws = Nothing
Exit Sub
ErrHandler:
Debug.Print Err.Description
Resume ExitPoint
End Sub
'向工作表菜单栏中添加新菜单项
Private Function AddTopLevelItem(rg As Range) As CommandBarControl
Dim cbWSMenuBar As CommandBar
Dim cbc As CommandBarControl
On Error GoTo ErrHandler
Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
'添加菜单项
Set cbc = cbWSMenuBar.Controls.Add(msoControlPopup, , , , True)
cbc.Tag = rg.Offset(0, TAG_OFFSET).Value
cbc.DescriptionText = rg.Offset(0, DESCRIPTION_OFFSET).Value
cbc.Caption = rg.Offset(0, CAPTION_OFFSET).Value
'返回新添加的菜单项
Set AddTopLevelItem = cbc
ExitPoint:
Set cbc = Nothing
Set cbWSMenuBar = Nothing
Exit Function
ErrHandler:
Set AddTopLevelItem = Nothing
Resume ExitPoint
End Function
Private Function AddSubItem(rg As Range) As CommandBarControl
Dim cbcParent As CommandBarControl
Dim cbc As CommandBarControl
On Error GoTo ErrHandler
'基于父标记定位父菜单
Set cbcParent = Application.CommandBars.FindControl(, , rg.Value)
If Not cbcParent Is Nothing Then
'添加菜单项
Set cbc = cbcParent.Controls.Add(GetType(rg))
'确保该菜单项具有一个OnAction值而不是N/A
If rg.Offset(0, ONACTION_OFFSET).Value <> NA Then
cbc.OnAction = rg.Offset(0, ONACTION_OFFSET).Value
End If
cbc.Tag = rg.Offset(0, TAG_OFFSET).Value
cbc.DescriptionText = rg.Offset(0, DESCRIPTION_OFFSET).Value
cbc.Caption = rg.Offset(0, CAPTION_OFFSET).Value
cbc.BeginGroup = rg.Offset(0, BEGINGROUP_OFFSET).Value
'返回新添加的控件
Set AddSubItem = cbc
Else
'不能找到父控件-返回无
Set AddSubItem = Nothing
End If
ExitPoint:
Set cbc = Nothing
Set cbcParent = Nothing
Exit Function
ErrHandler:
Debug.Print Err.Description
Set AddSubItem = Nothing
Resume ExitPoint
End Function
'将所选的msoControlType枚举转换为值
Private Function GetType(rg As Range) As Long
Dim sType As String
sType = rg.Offset(0, TYPE_OFFSET).Value
Select Case sType
Case Is = "msoControlPopup"
GetType = msoControlPopup
Case Is = "msoControlButton"
GetType = msoControlButton
Case Is = "msoControlDropDown"
GetType = msoControlDropdown
Case Else '包括N/A
'默认为msoControlPopup
GetType = msoControlPopup
End Select
End Function
'删除标记为"MyMenu2"的控件
Sub DeleteMyMenu2()
DeleteMenu "MyMenu2"
End Sub
'删除标记为"MyMenu3"的控件
Sub DeleteMyMenu3()
DeleteMenu "MyMenu3"
End Sub
Private Sub DeleteMenu(sTag As String)
Dim cbc As CommandBarControl
Set cbc = Application.CommandBars.FindControl(Tag:=sTag)
If Not cbc Is Nothing Then
cbc.Delete
End If
Set cbc = Nothing
End Sub
