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

fanjy

发布于 2022-11-16 11:21:33

1.7K0

发布于 2022-11-16 11:21:33

文章被收录于专栏：完美Excel

标签：VBA，用户界面

本文接上篇文章：

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

使用RibbonX将控件添加到单元格上下文菜单

在下面的示例中，将创建与上文描述的示例相同的按钮和子菜单，但使用RibbonX创建。

1.打开一个新工作簿，将其保存为启用宏的工作簿（.xlsm）。

2.关闭该工作簿。

3.在Custom UI Editor中打开这个工作簿。

4.单击菜单“插入——Office 2010+定制UI”。

5.在Custom UI Editor中输入下面的XML：

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
<contextMenus>
<contextMenu idMso="ContextMenuCell">
<button idMso="FileSave" insertBeforeMso="Cut" />
<button id="MyButton" label="切换大写/小写/合适"
insertBeforeMso="Cut"
onAction="ToggleCaseMacro"
imageMso="HappyFace"/>
<menu id="MySubMenu" label="大小写转换菜单" insertBeforeMso="Cut"  >
<button id="Menu1Button1" label="大写"
imageMso="U" onAction="UpperMacro"/>
<button id="Menu1Button2" label="小写"
imageMso="L" onAction="LowerMacro"/>
<button id="Menu1Button3" label="合适的大小写"
imageMso="P" onAction="ProperMacro"/>
</menu>
<menuSeparator id="MySeparator" insertBeforeMso="Cut" />
</contextMenu>
</contextMenus>
</customUI>

如下图3所示。

图3

6.保存并关闭编辑器。

7.在Excel中打开该工作簿。

8.在VBE的标准模块中粘贴或输入下面的代码：

Sub ToggleCaseMacro(control As IRibbonControl)
    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))
    If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange
        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(control As IRibbonControl)
    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))
    If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange
        cell.Value = UCase(cell.Value)
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Sub LowerMacro(control As IRibbonControl)
    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))
     If CaseRange Is Nothing Then Exit Sub
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange
        cell.Value = LCase(cell.Value)
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Sub ProperMacro(control As IRibbonControl)
    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))
    If CaseRange Is Nothing Then Exit Sub
    With Application
         CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each cell In CaseRange
        cell.Value = StrConv(cell.Value, vbProperCase)
    Next cell
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

9.在该工作簿中，右键单击包含文本的单元格，查看单元格上下文菜单是否已更改。

10.选择该上下文菜单中添加的自定义选项，查看其对单元格文本的影响。

要使用内置命令添加自定义按钮，将语句：

替换为下面的语句：

接下来，在VBE中，添加由onAction属性调用的宏。

Sub BuiltInSaveCommand(control As IRibbonControl)
    CommandBars.ExecuteMso "FileSave"
End Sub

此外，还可以使用ActiveWorkbook.Save方法。然而，通过使用ExecuteMso方法，可以在Microsoft Office Fluent UI上执行任何内置控件。

使用VBA代码或RibbonX将动态菜单添加到单元格上下文菜单

动态菜单指向在运行时创建菜单的回调过程。dynamicMenu控件包含指向GetContent回调过程的getContent属性。

下面是在单元格上下文菜单中创建动态菜单的RibbonX XML。

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
<contextMenus>
<contextMenu idMso="ContextMenuCell">
<dynamicMenu id="MyDynamicMenu"
label= "我的动态菜单" imageMso="HappyFace"
getContent="GetContent" insertBeforeMso="Cut"/>
</contextMenu>
</contextMenus>
</customUI>

如下图4所示。

图4

例如，下面的VBA代码在运行时使用两个按钮构建动态菜单，这意味着只有单击上下文菜单上的菜单控件才能创建动态菜单。

Sub GetContent(control As IRibbonControl, ByRef returnedVal)
    Dim xml As String
    xml = "<menu http://schemas.microsoft.com/office/2009/07/customui"">" & _
"<button id=""but1"" imageMso=""Help"" label=""帮助"" onAction=""HelpMacro""/>" & _
"<button id=""but2"" imageMso=""FindDialog"" label=""查找"" onAction=""FindMacro""/>" & _
"</menu>"
    returnedVal = xml
End Sub
Sub HelpMacro(control As IRibbonControl)
    MsgBox "Help macro"
End Sub
Sub FindMacro(control As IRibbonControl)
    MsgBox "Find macro"
End Sub

本文参与腾讯云自媒体同步曝光计划，分享自微信公众号。

原始发表：2022-07-16，如有侵权请联系 cloudcommunity@tencent.com 删除

编程算法