上下文菜单（右键单击菜单）Excel：只能在一本书中使用，我希望它可以在任何地方使用

我有带有

“ContextMenu”代码（XML+VBA）

的书。一切都很好，但不是所有的书。代码有两种变体。1-从Excel手册开始；2-单击“上下文菜单”中的按钮后工作

我使用了这些网站上描述的方法（两个网站都有相同的信息）。

我把代码现代化了一点。 下面是一本带有“动态菜单”的Excel书籍的发布代码

---

没什么帮助

您可以尝试这样的操作……当您右键单击时，将出现一个侧面菜单，用于

大写、小写和正楷

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

我明白了为什么它不起作用。

打开新工作簿，然后“另存为”右键单击菜单.xlam
然后把它放在这里
C:\Users\USER\AppData\Roaming\Microsoft\AddIns\
在提议的网站上，有两种“右键单击菜单”的变体。我决定不使用dynamicMenu，因为它工作得更快
打开我们的书已经在里面了↵ 或↵ 然后将XML代码粘贴到此处：
↴

我也有这个代码。如何在“动态菜单”中插入VBA中我自己的图标？@rediffusion这不是您想要的吗？它为你创建了一个辅助菜单…你所需要做的就是在这里和那里做一些事情来满足你的需求。您可以将
faceid
更改为其他内容。。。对你自己的img我不知道说实话从来没有试过。0K我抓到你了！我会用这个。但如果有人有有趣的代码，请随时与社区分享：）
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

Private Sub Workbook_Activate()

 Call AddToCellMenu End Sub

Private Sub Workbook_Deactivate()

 Call DeleteFromCellMenu End Sub

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