在Excel中自定义上下文菜单（上）

Sub AddToCellMenu()
    Dim ContextMenu As CommandBar
    Dim MySubMenu As CommandBarControl
    ' 首先删除控件以避免重复.
    Call DeleteFromCellMenu
    ' 将ContextMenu赋值为单元格上下文菜单.
    Set ContextMenu = Application.CommandBars("Cell")
    ' 在单元格上下文菜单中添加一个内置控件(Save = 3).
    ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1
    ' 在单元格上下文菜单中添加一个自定义按钮.
    With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2)
        .OnAction = "'" & ThisWorkbook.Name & "'!" & "ToggleCaseMacro"
        .FaceId = 59
        .Caption = "切换大写/小写/合适"
        .Tag = "My_Cell_Control_Tag"
    End With
    ' 添加包含三个按钮的自定义子菜单.
    Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3)
    With MySubMenu
        .Caption = "大小写转换菜单"
        .Tag = "My_Cell_Control_Tag"
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "UpperMacro"
            .FaceId = 100
            .Caption = "大写"
        End With
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "LowerMacro"
            .FaceId = 91
            .Caption = "小写"
        End With
        With .Controls.Add(Type:=msoControlButton)
              .OnAction = "'" & ThisWorkbook.Name & "'!" & "ProperMacro"
            .FaceId = 95
            .Caption = "合适的大小写"
        End With
    End With
    ' 在单元格上下文菜单中添加分隔符.
    ContextMenu.Controls(4).BeginGroup = True
End Sub
Sub DeleteFromCellMenu()
    Dim ContextMenu As CommandBar
    Dim ctrl As CommandBarControl
    ' 将ContextMenu赋值为单元格上下文菜单.
    Set ContextMenu = Application.CommandBars("Cell")
    ' 删除标签为My_Cell_Control_Tag的自定义控件.
    For Each ctrl In ContextMenu.Controls
        If ctrl.Tag = "My_Cell_Control_Tag" Then
            ctrl.Delete
        End If
    Next ctrl
    ' 删除自定义的内置保存按钮.
    On Error Resume Next
    ContextMenu.FindControl(ID:=3).Delete
    On Error GoTo 0
End Sub
Sub ToggleCaseMacro()
    Dim CaseRange As Range
    Dim CalcMode As Long
    Dim cell As Range
    On Error Resume Next
    Set CaseRange = Intersect(Selection, _
    Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange.Cells
        Select Case cell.Value
    Case UCase(cell.Value): cell.Value = LCase(cell.Value)
    Case LCase(cell.Value): cell.Value = StrConv(cell.Value, vbProperCase)
        Case Else: cell.Value = UCase(cell.Value)
        End Select
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Sub UpperMacro()
    Dim CaseRange As Range
    Dim CalcMode As Long
    Dim cell As Range
    On Error Resume Next
    Set CaseRange = Intersect(Selection, _
    Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange.Cells
        cell.Value = UCase(cell.Value)
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Sub LowerMacro()
    Dim CaseRange As Range
    Dim CalcMode As Long
    Dim cell As Range
    On Error Resume Next
    Set CaseRange = Intersect(Selection, _
    Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange.Cells
        cell.Value = LCase(cell.Value)
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Sub ProperMacro()
    Dim CaseRange As Range
    Dim CalcMode As Long
    Dim cell As Range
    On Error Resume Next
    Set CaseRange = Intersect(Selection, _
    Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange.Cells
        cell.Value = StrConv(cell.Value, vbProperCase)
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Private Sub Workbook_Activate()
Call AddToCellMenu
End Sub
Private Sub Workbook_Deactivate()
Call DeleteFromCellMenu
End Sub