Customizing Right-Click Context Menu In Excel For CommandBars Cell Row And Column

I have compiled a set of macros and user forms (lets call them extras) and I have managed to place them in the context menu of the cell.
I have used the logic described in this article. Check the code of AddToCellMenu and DeleteFromCellMenu Subs.

It worked on one or more cells perfectly, however I realized that when I right clicked a row or column the context menu did not have the extras.

It applied on one or more cells cause I have used

Code:

---

Dim ContextMenu As CommandBar
Set ContextMenu = Application.CommandBars("Cell")

---

but in order to make it work for rows context menu I have to use

Code:

---

Dim ContextMenu As CommandBar
Set ContextMenu = Application.CommandBars("Rows")

---

and for columns context menu use

Code:

---

Dim ContextMenu As CommandBar
Set ContextMenu = Application.CommandBars("Columns")

---

I would like to combine them somehow so as not to repeat unnecessarily lines of code for each context menu so as to apply the extras, especially if you think that they are in several submenus also...
Please advise... and thank you in advance for any idea.

Take out the Workbook_Activate event. And use the code below to which I've made some modifications

Code:

---

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
   
    If Target.Columns.Count = Columns.Count Then
        Call AddToCellMenu("Row")
    ElseIf Target.Rows.Count = Rows.Count Then
        Call AddToCellMenu("Column")
    Else
        Call AddToCellMenu("Cell")
    End If
   
End Sub

Private Sub Workbook_Deactivate()

    Call DeleteFromCellMenu
   
End Sub

Sub AddToCellMenu(strCommandBarName As String)

    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(strCommandBarName)

    ' 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
    Dim lng As Long
    Const strBarNames As String = "Cell,Column,Row"
    ' Set ContextMenu to the Cell context menu.
    For lng = LBound(Split(strBarNames, ",")) To UBound(Split(strBarNames, ","))
        Set ContextMenu = Application.CommandBars(Split(strBarNames, ",")(lng))
   
        ' 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
    Next lng
    ' Delete the custom built-in Save button.
    While Not ContextMenu.FindControl(ID:=3) Is Nothing
        ContextMenu.FindControl(ID:=3).Delete
    Wend
   
End Sub

---

Very interesting, can you paste the whole code or attach a sample file ? some subs are missing

Sure Patel.

Code:

---

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
   
    If Target.Columns.Count = Columns.Count Then
        Call AddToCellMenu("Row")
    ElseIf Target.Rows.Count = Rows.Count Then
        Call AddToCellMenu("Column")
    Else
        Call AddToCellMenu("Cell")
    End If
   
End Sub

Private Sub Workbook_Deactivate()

    Call DeleteFromCellMenu
   
End Sub

Sub AddToCellMenu(strCommandBarName As String)

    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(strCommandBarName)

    ' 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
    Dim lng As Long
    Const strBarNames As String = "Cell,Column,Row"
    ' Set ContextMenu to the Cell context menu.
    For lng = LBound(Split(strBarNames, ",")) To UBound(Split(strBarNames, ","))
        Set ContextMenu = Application.CommandBars(Split(strBarNames, ",")(lng))
   
        ' Delete the custom controls with the Tag : My_Cell_Control_Tag.
        For Each ctrl In ContextMenu.Controls
            If ctrl.ID = 3 Or ctrl.Tag = "My_Cell_Control_Tag" Then
                ctrl.Delete
            End If
        Next ctrl
    Next lng
   
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

---

Thanks for the code.
I think ther'is a bug , now I have this right clic menu , without added Items, but with many save items, how can I reset it ?

Patel, yes you are right. I missed that one. I've corrected that above.

Sorry but.... which code is the correct?

The one in post #4

Ok, thank you, it works well now.

I have managed to make the adjustments needed for my set of macros and extra options needed in the context menu and it works if I make it on an xlsm file.

However since I needed this to work on all the instances of excel, I thought that I should place it on personal macro workbook or at least save the xlsm as add-in (xlam).

Sadly none of these options worked so wherever I right-click nothing happens. In none of the 2 options available...

Any suggestion??
Thanks again in advance!