标签：VBA，用户界面
上下文菜单（也称为快捷菜单）是在一些随用户交互之后出现的菜单，通常是鼠标右键单击操作。在Microsoft Office中，上下文菜单提供了一组在应用程序的当前状态或上下文中可用的有限选项。通常，可用的选择是与选定对象（如单元格或列）相关的操作。
Excel中的上下文菜单
在Microsoft Excel中，人们最常用的上下文菜单是单元格上下文菜单，这是在工作表单元格或选定单元格上单击鼠标右键时看到的菜单（如下图1所示）。然而，也可以自定义许多其他上下文菜单。例如，在行或列标题上单击鼠标右键时显示的行和列上下文菜单。
图1
在Excel中自定义上下文菜单
在Excel 2007以前的版本中自定义上下文菜单的唯一方法是使用VBA代码，然而，在Excel 2007后续版本中，还可以使用相同的功能区扩展性（RibbonX）模型更改上下文菜单。RibbonX模型用于自定义Microsoft Office Fluent用户界面的其他组件，包括功能区和后台视图。
使用RibbonX自定义上下文菜单的优点之一是，可以添加无法使用VBA添加的控件。下面列出了可以添加到上下文菜单的控件：
- 按钮（button）
- 复选框（checkBox）
- 控件（control）
- 动态菜单（dynamicMenu）
- 库（gallery）
- 菜单（menu）
- 菜单分隔条（menuSeparator）
- 拆分按钮（splitButton）
- 切换按钮（toggleButton）
使用VBA代码将控件添加到单元格上下文菜单
下面的示例在单元格上下文菜单顶部添加了自定义按钮、内置按钮（保存）和子菜单。
注意，Excel中有两个单元格上下文菜单，一个是标准菜单，另一个是在分页预览模式下的菜单。分页预览模式显示每页上显示的数据，并使用户能够快速调整打印区域和分页符。要激活分页预览模式，在功能区上单击“视图”，然后单击“分页预览”。如果要更改第二种菜单类型，使用以下语句：
Set ContextMenu=Application.CommandBars(Application.CommandBars(“Cell”).Index 3
该信息也适用于行和列上下文菜单。
要自定义单元格上下文菜单，按Alt F11打开VBE，单击菜单“插入——模块”。在模块中粘贴或键入下面6个过程。第一个过程将控件添加到单元格上下文菜单中，第二个过程从单元格上下文菜单中删除控件。注意，如何添加标记到该控件，然后用其删除控件。单击按钮或子菜单中的三个选项之一时，会运行其他四个过程。在本例中，最后四个宏更改单元格中任何文本的大小写。
下面是6个过程的代码：
代码语言：javascript复制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将下面两个事件过程复制到工作簿的ThisWorkbook模块中。当打开或激活该工作簿时，这些事件会自动将控件添加到单元格上下文菜单中；当关闭或停用该工作簿时，这些事件会自动删除添加的控件。
代码语言：javascript复制Private Sub Workbook_Activate()
Call AddToCellMenu
End Sub
Private Sub Workbook_Deactivate()
Call DeleteFromCellMenu
End Sub接下来，保存、关闭并重新打开该工作簿，以查看单元格上下文菜单中的更改，如图2所示。
图2
