完美Excel

Sub WBDisplayPopUp()
' If ActiveWorkbook.Name = ThisWorkbook.Name Then
    On Error Resume Next
    Application.CommandBars(ThisWorkbook.Sheets("MenuSheet").Range("B2").Value).ShowPopup
    On Error GoTo 0
' End If
End Sub

Sub CreateMenu()
'   打开工作簿时执行本过程
'   注: 在本过程中没有编写错误处理的代码

    Dim MenuSheet As Worksheet
    Dim MenuObject As CommandBarPopup
 
    Dim MenuItem As Object
    Dim SubMenuItem As CommandBarButton
    Dim Row As Integer
    Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId
 
''''''''''''''''''''''''''''''''''''''''''''''''''''
'   菜单数据所在的工作表
    Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
''''''''''''''''''''''''''''''''''''''''''''''''''''

'   确保不会出现重复菜单
    Call DeleteMenu
 
'   初始化行计数器
    Row = 2
 
'   使用存储在MenuSheet工作表中的数据添加菜单,菜单项和子菜单项
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        With MenuSheet
            MenuLevel = .Cells(Row, 1)
            Caption = .Cells(Row, 2)
            PositionOrMacro = .Cells(Row, 3)
            Divider = .Cells(Row, 4)
            FaceId = .Cells(Row, 5)
            NextLevel = .Cells(Row + 1, 1)
        End With
 
        Select Case MenuLevel
            Case 1 ' 代表菜单
'              在工作表命令栏中添加顶级菜单
                Set MenuObject = Application.CommandBars(1). _
                    Controls.Add(Type:=msoControlPopup, _
                    Before:=PositionOrMacro, _
                    Temporary:=True)
                MenuObject.Caption = Caption
 
            Case 2 ' 代表菜单项
                If NextLevel = 3 Then
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
                Else
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
                    MenuItem.OnAction = PositionOrMacro
                End If
                MenuItem.Caption = Caption
                If FaceId <> "" Then MenuItem.FaceId = FaceId
                If Divider Then MenuItem.BeginGroup = True
 
            Case 3 ' 代表子菜单项
                Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
                SubMenuItem.Caption = Caption
                SubMenuItem.OnAction = PositionOrMacro
                If FaceId <> "" Then SubMenuItem.FaceId = FaceId
                If Divider Then SubMenuItem.BeginGroup = True
        End Select
        Row = Row + 1
    Loop
End Sub
 
Sub DeleteMenu()
'   关闭工作簿时执行本过程
'   删除创建的菜单
    Dim MenuSheet As Worksheet
    Dim Row As Integer
    Dim Caption As String
 
    On Error Resume Next
    Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
    Row = 2
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        If MenuSheet.Cells(Row, 1) = 1 Then
            Caption = MenuSheet.Cells(Row, 2)
            Application.CommandBars(1).Controls(Caption).Delete
        End If
        Row = Row + 1
    Loop
    On Error GoTo 0
End Sub
 
Sub DummyMacro()
    MsgBox "这里一个用于演示的宏."
End Sub

Private Sub Workbook_Open()
    Call CreateMenu
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call DeleteMenu
End Sub

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("Menu Builder")
  '从第二行开始,因为第一行已经包含了列标题
  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
 
'删除标记为"我的菜单1"的控件
Sub DeleteMyMenu1()
  DeleteMenu "我的菜单1"
End Sub
 
'删除标记为"我的菜单2"的控件
Sub DeleteMyMenu2()
  DeleteMenu "我的菜单2"
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

Private Sub Workbook_Open()
    Set cb_Red = CreateSubMenu("红色")
    Set cb_Yellow = CreateSubMenu("黄色")
    Set cb_Green = CreateSubMenu("绿色")
    Call SetupAllWSEvents
End Sub

Global cb_Red As CommandBar
Global cb_Yellow As CommandBar
Global cb_Green As CommandBar
Global WSObj As Collection
Global ws As Worksheet
 
Sub SetupAllWSEvents()
 
    Dim WSo As clsWs
    Set WSObj = Nothing
    Set WSObj = New Collection
    For Each ws In ActiveWorkbook.Worksheets
        Set WSo = New clsWs
        Set WSo.WSToMonitor = ws
        WSObj.Add WSo, ws.Name
    Next ws
 
End Sub
 
Function CreateSubMenu(strCB) As CommandBar
 
    Const CBPREFIX = "CustomPopUp"
    Dim cb As CommandBar
    Dim cbc As CommandBarControl
    Dim strCBName As String
    '自定义菜单名称
    strCBName = CBPREFIX & strCB
    '移除以前的实例
    Call DeleteCommandBar(strCBName)
   '添加弹出菜单到CommandBars集合
    Set cb = CommandBars.Add(Name:=strCBName, _
        Position:=msoBarPopup, _
        MenuBar:=False, _
        Temporary:=False)
    '添加控件
    Set cbc = cb.Controls.Add
    With cbc
        .Caption = strCB & " 控件 1"
        .OnAction = "DummyMessage"
    End With
 
    Set cbc = cb.Controls.Add
    With cbc
        .Caption = strCB & " 控件 2"
        .OnAction = "DummyMessage"
    End With
 
    Set CreateSubMenu = cb
    Set cbc = Nothing
    Set cb = Nothing
 
End Function
Sub DeleteCommandBar(cbName)
 
    On Error Resume Next
    CommandBars(cbName).Delete
 
End Sub
Sub DummyMessage()
    MsgBox CommandBars.ActionControl.Caption, vbInformation + vbOKOnly, "Dummy Message"
End Sub

Dim WithEvents aWS As Worksheet
 
Property Set WSToMonitor(uWS As Worksheet)
    Set aWS = uWS
End Property
 
Private Sub aWS_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Select Case Target.Interior.ColorIndex
        Case 3, 9
        cb_Red.ShowPopup
        Cancel = True '使标准的单元格弹出菜单失效
    Case 4, 10, 14, 35, 43, 50, 51, 52
        cb_Green.ShowPopup
        Cancel = True
    Case 6, 12, 36, 44
        cb_Yellow.ShowPopup
        Cancel = True
    Case Else
        Cancel = False
    End Select
End Sub