完美Excel

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