Add to Right Click Menu (Context Menu)
Here we have the ability to add to the Context Menu, sometimes known as the right click menu.
Most websites are helpful with the below however few offered insight on how to make your newly created buttons activate on the context menu when using tables. Here's the beared fruit of my research.
Firstly we need to put two codes into the ThisWorkbook Module, these 2 codes call macros from the Standard Modules which reset the context menu and then add your buttons each time the workbook is activated.
In the Standard Module place the 2 codes that (1) reset the context menu and (2) add to the context menu.
Download copy of code:
Add the following to the ThisWorkbook Module
Private Sub Workbook_Activate() Call AddToRightClickMenu
End Sub
''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Workbook_Deactivate() Call DeleteRightClickMenu End Sub
Add the folowing to a Standard Module, codes to add and reset the context menu
Sub DeleteRightClickMenu() On Error Resume Next 'Range right click CommandBars("cell").Reset 'Table right click Application.CommandBars("List Range Popup").Reset End Sub
''''''''''''''''''''''''''''''''''''''''''''''
Sub AddToRightClick() Dim cmdNew As CommandBarButton 'CONTEXT MENU FOR CELLS IN A TABLE With CommandBars("List Range Popup") .Reset With .Controls.Add .Caption = "UPPER CASE" .OnAction = "UpperCase" .FaceId = 100 .BeginGroup = True End With With .Controls.Add .Caption = "Proper Case" .OnAction = "ProperCase" .FaceId = 95 End With With .Controls.Add .Caption = "lower case" .OnAction = "LowerCase" .FaceId = 91 End With With .Controls.Add .Caption = "Sentence case" .OnAction = "SentenceCase" .FaceId = 98 End With
End With
'CONTEXT MENU FOR CELLS IN A NORMAL RANGE With Application.CommandBars("Cell") .Reset With .Controls.Add .Caption = "UPPER CASE" .OnAction = "UpperCase" .FaceId = 100 .BeginGroup = True End With With .Controls.Add .Caption = "Proper Case" .OnAction = "ProperCase" .FaceId = 95 End With With .Controls.Add .Caption = "lower case" .OnAction = "LowerCase" .FaceId = 91 End With With .Controls.Add .Caption = "Sentence case" .OnAction = "SentenceCase" .FaceId = 98 End With
End With End Sub
''''''''''''''''''''''''''''''''''''''''''''''
Add the Codes that you are adding to the context menu.
Note that the name of each macro MUST be the same as the text in 'OnAction'
Sub UpperCase() 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 LowerCase() 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 ProperCase() 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
Sub SentenceCase() Dim Rng As Range Dim WorkRng As Range On Error Resume Next Set WorkRng = Application.Selection For Each Rng In WorkRng xValue = Rng.Value xStart = True For I = 1 To VBA.Len(xValue) Ch = Mid(xValue, I, 1) Select Case Ch Case "." xStart = True Case "?" xStart = True Case "a" To "z" If xStart Then Ch = UCase(Ch) xStart = False End If Case "A" To "Z" If xStart Then xStart = False Else Ch = LCase(Ch) End If End Select Mid(xValue, I, 1) = Ch Next Rng.Value = xValue Next End Sub
