افزودن Case Menu به راست کلیک در ورک شیت

[mokaram]

با سلام خدمت دوستان با افزودن کد های زیر تو یک ماژول ، منوی Case Menu به راست کلیک در ورک شیت اضافه میشه جالبه

Sub AddToCellMenu()
Dim ContextMenu As CommandBar
Dim MySubMenu As CommandBarControl
Call DeleteFromCellMenu
Set ContextMenu = Application.CommandBars("Cell")

ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1
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

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

ContextMenu.Controls(4).BeginGroup = True
End Sub

Sub DeleteFromCellMenu()
Dim ContextMenu As CommandBar
Dim ctrl As CommandBarControl

Set ContextMenu = Application.CommandBars("Cell")

For Each ctrl In ContextMenu.Controls
If ctrl.Tag = "My_Cell_Control_Tag" Then
ctrl.Delete
End If
Next ctrl

On Error Resume Next
ContextMenu.FindControl(ID:=3).Delete
On Error GoTo 0
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_Activate()
Call AddToCellMenu
End Sub


Private Sub Workbook_Deactivate()
Call DeleteFromCellMenu
End Sub


حالا سیو کرده و یک بار فایل را بسته و مجدد اجرا کرده و روی یکی از سل ها راست کلیک کنید
پیروز باشید