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

**patel** · 08-05-2013, 10:32 PM

http://msdn.microsoft.com/en-us/libr...ice.14%29.aspx

**Excel Fox** · 08-05-2013, 11:41 PM

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

Code:

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** · 08-06-2013, 12:26 AM

Actually I have placed only this in ThisWorkbook

Code:

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

Code:

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

Code:

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** · 08-06-2013, 01:36 AM

I believe that it will do just fine also in xlam

Yes it should

**patel** · 08-06-2013, 09:05 AM

Originally Posted by 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.

I think it would be enough to eliminate this sub to make the manu change permanent

Code:

Private Sub Workbook_Deactivate()
    Call DeleteFromCellMenu
End Sub

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

Thread Tools

Search Thread

Display

Similar Threads

Highlight A Cell Using Conditional Format Using Row And Column Index

Highlight Active Cell’s Row and Column

Pass Row and Column Number Index To Refer And Put Value To Cell Range

Lookup From Cell Range By Matching Row and Column

Add Control To Right-Click Cell Context Menu

Bookmarks

Bookmarks

Posting Permissions