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.
Reply With Quote
Originally Posted by Excel Fox
Bookmarks