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

[MrBlackd]

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 (http://msdn.microsoft.com/en-us/library/office/gg469862(v=office.14).aspx). 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

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

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

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


and for columns context menu use

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.

[Excel Fox]

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



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

[patel]

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

[Excel Fox]

Sure Patel.



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

[patel]

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 ?

[Excel Fox]

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

[MrBlackd]

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

[Excel Fox]

The one in post #4

[patel]

Ok, thank you, it works well now.

[MrBlackd]

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!

[patel]

http://msdn.microsoft.com/en-us/library/office/gg469862%28v=office.14%29.aspx

[Excel Fox]

You will not be able to trigger workbook level events across your application unless you create application level events using the WithEvents keyword.

Paste this entire code in the ThisWorkbook class module of the Personal macro workbook, save and restart excel


Option Explicit

Public WithEvents App As Application

Private Sub App_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 App_WorkbookDeactivate(ByVal Wb As Workbook)

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 & "'!ThisWorkbook." & "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 & "'!ThisWorkbook." & "UpperMacro"
.FaceId = 100
.Caption = "Upper Case"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!ThisWorkbook." & "LowerMacro"
.FaceId = 91
.Caption = "Lower Case"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!ThisWorkbook." & "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

Private Sub Workbook_Open()

Set App = Application

End Sub

[MrBlackd]

Actually I have placed only this in ThisWorkbook


Option Explicit

Public WithEvents App As Application

Private Sub App_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 App_WorkbookDeactivate(ByVal Wb As Workbook)

Call DeleteFromCellMenu

End Sub
Private Sub Workbook_Open()

Set App = Application

End Sub



This in a Module called Context_Menus


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 & "'!ThisWorkbook." & "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 & "'!ThisWorkbook." & "UpperMacro"
.FaceId = 100
.Caption = "Upper Case"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!ThisWorkbook." & "LowerMacro"
.FaceId = 91
.Caption = "Lower Case"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!ThisWorkbook." & "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

And finally another module that holds the actual macros


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

And it works just fine in personal macro workbook.

I believe that it will do just fine also in xlam ;)

Thank you very much for all the trouble you ve gone into.

I promise to share the addin with my exras as soon as it is tested properly.

[Excel Fox]

I believe that it will do just fine also in xlam ;) Yes it should

[patel]

You will not be able to trigger workbook level events across your application unless you create application level events using the WithEvents keyword.
I think it would be enough to eliminate this sub to make the manu change permanent

Private Sub Workbook_Deactivate()
Call DeleteFromCellMenu
End Sub