Custom Right Click Menu (context Menu)
Easily add a custom right click menu for both normal ranges and in tables! First 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.
Add the following To the ThisWorkbook Module
Private Sub Workbook_Activate()
'// Add to the Context Menu
Call AddToRightClickMenu
End Sub
Private Sub Workbook_Deactivate()
'// Reset the Context Menu
Call ResetRightClickMenu
End Sub
Reset the context menu code
Sub ResetRightClickMenu()
On Error Resume Next
'// Reset the context menu for cell ranges
CommandBars("cell").Reset
'// Reset the context menu for tables
Application.CommandBars("List Range Popup").Reset
End Sub
Add the following To a Standard Module
Codes to add and reset the context menu.
Add your Macro buttons to the context menu code.
Sub AddToRightClickMenu()
'// vars
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