excel - 上下文菜单 (RightClickMenu) Excel : Works only in one book, 我希望它可以在任何地方工作

Question

我有 "ContextMenu" code (XML + VBA) 的书.一切都很好，但不是所有的书。该代码有 2 个变体。 1 - 从 Excel 书开始； 2 - 单击“上下文菜单”中的按钮后工作。

我使用了这些站点上描述的方法(两个站点具有相同的信息)。
microsoft
rondebruin

我对代码进行了一些现代化改造。
下面发布带有“动态菜单”的一本 Excel 书籍的代码。

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
   <contextMenus>
      <contextMenu idMso="ContextMenuCell">
         <dynamicMenu 
            id="MyDynamicMenu" 
            label= "My Dynamic Menu" 
            imageMso="HappyFace" 
            getContent="GetContent" 
            insertBeforeMso="Cut"/>
      </contextMenu>
   </contextMenus>
</customUI>

Option Explicit

'MyDynamicMenu (component: dynamicMenu, attribute: getContent), 2010+
Sub GetContent(control As IRibbonControl, ByRef returnedVal)
    Dim xml As String

        xml = "<menu xmlns=""http://schemas.microsoft.com/office/2009/07/customui"">" & _
              "<button id=""but1"" imageMso=""Help"" label=""About"" onAction=""HelpMacro""/>" & _
              "<button id=""but2"" imageMso=""FindDialog"" label=""Find information"" onAction=""FindMacro""/>" & _
              "<menu id=""MyMacroSubMenu"" label=""Macro Sub-Menu"" itemSize=""large"">" & _
              "<button id=""Sub1But1"" imageMso=""AppointmentColor1"" label=""Macro1"" onAction=""Macro1"" description=""Description Macro1""/>" & _
              "<button id=""Sub1But2"" imageMso=""AppointmentColor2"" label=""Macro3"" onAction=""Macro2"" description=""Description Macro2""/>" & _
              "<button id=""Sub1But3"" imageMso=""AppointmentColor3"" label=""Macro3"" onAction=""Macro3"" description=""Description Macro3""/>" & _
              "</menu>" & _
              "</menu>"

    returnedVal = xml
End Sub

'Callback for macro
Sub FindMacro(control As IRibbonControl)
    MsgBox "Find macro"
End Sub

Sub Macro1(control As IRibbonControl)
    MsgBox "Macro 1 in menu"
End Sub

Sub Macro2(control As IRibbonControl)
    MsgBox "Macro 2 in menu"
End Sub

Sub Macro3(control As IRibbonControl)
    MsgBox "Macro 3 in menu"
End Sub

==============================================

我尝试通过 - 开发人员 > 加载项

添加

将代码放入 - C:\Users[MyPC]\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB

此外，当我输入此代码时，我收到一个错误:

Private Sub Workbook_Activate()

 Call AddToCellMenu End Sub

Private Sub Workbook_Deactivate()

 Call DeleteFromCellMenu End Sub

没有任何帮助!？

Answer 1

您可以尝试这样的操作...当您右键单击时，将出现一个用于 upper case, lower case, proper case 的侧边菜单.

Sub AddToCellMenu()

    Dim ContextMenu As CommandBar
    Dim MySubMenu As CommandBarControl

    ' Delete the controls first to avoid duplicates.
    Call DeleteFromCellMenu

    ' Set ContextMenu to the Cell context menu.
    Set ContextMenu = Application.CommandBars("Cell")

    ' Add one built-in button(Save = 3) to the Cell context menu.
    ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1

    ' Add one custom button to the Cell context menu.
    With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2)
        .OnAction = "'" & ThisWorkbook.Name & "'!" & "ToggleCaseMacro"
        .FaceId = 59
        .Caption = "Toggle Case Upper/Lower/Proper"
        .Tag = "My_Cell_Control_Tag"
    End With

    ' Add a custom submenu with three buttons.
    Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3)

    With MySubMenu
        .Caption = "Case Menu"
        .Tag = "My_Cell_Control_Tag"

        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "UpperMacro"
            .FaceId = 100
            .Caption = "Upper Case"
        End With
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "LowerMacro"
            .FaceId = 91
            .Caption = "Lower Case"
        End With
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "ProperMacro"
            .FaceId = 95
            .Caption = "Proper Case"
        End With
    End With

    ' Add a separator to the Cell context menu.
    ContextMenu.Controls(4).BeginGroup = True
End Sub

Sub DeleteFromCellMenu()
    Dim ContextMenu As CommandBar
    Dim ctrl As CommandBarControl

    ' Set ContextMenu to the Cell context menu.
    Set ContextMenu = Application.CommandBars("Cell")

    ' Delete the custom controls with the Tag : My_Cell_Control_Tag.
    For Each ctrl In ContextMenu.Controls
        If ctrl.Tag = "My_Cell_Control_Tag" Then
            ctrl.Delete
        End If
    Next ctrl

    ' Delete the custom built-in Save button.
    On Error Resume Next
    ContextMenu.FindControl(ID:=3).Delete
    On Error GoTo 0
End Sub

Sub ToggleCaseMacro()
    Dim selectedRange As Range
    Dim cell As Range

    On Error Resume Next
    Set selectedRange = Intersect(Selection, _
        Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If selectedRange Is Nothing Then Exit Sub

    Application.ScreenUpdating = False

    For Each cell In selectedRange.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

    Application.ScreenUpdating = True

End Sub

Sub UpperMacro()
    Dim selectedRange As Range
    Dim cell As Range

    On Error Resume Next
    Set selectedRange = Intersect(Selection, _
        Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If selectedRange Is Nothing Then Exit Sub

Application.ScreenUpdating = False

    For Each cell In selectedRange.Cells
        cell.value = UCase(cell.value)
    Next cell

Application.ScreenUpdating = True

End Sub

Sub LowerMacro()
    Dim selectedRange As Range
    Dim cell As Range

    On Error Resume Next
    Set selectedRange = Intersect(Selection, _
        Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If selectedRange Is Nothing Then Exit Sub

Application.ScreenUpdating = False

    For Each cell In selectedRange.Cells
        cell.value = LCase(cell.value)
    Next cell

Application.ScreenUpdating = True

End Sub

Sub ProperMacro()
    Dim selectedRange As Range
    Dim cell As Range

    On Error Resume Next
    Set selectedRange = Intersect(Selection, _
        Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    On Error GoTo 0
    If selectedRange Is Nothing Then Exit Sub

Application.ScreenUpdating = False

    For Each cell In selectedRange.Cells
        cell.value = StrConv(cell.value, vbProperCase)
    Next cell

Application.ScreenUpdating = True

End Sub