أختيار بكليك يمين فى الاكسيل

[ابن الملك]

الى كل أساتذة منتدى اوفيسنا

 

هو ممكن طبعا نضيف اوامر فى كليك يمين فى الاكسيل 

 

لكن هو فى طريقة تخليها تتقسم جروبات 

أو أنها تظهر جنبها اختيارات تانية مثل المرفق دة 

 

 

وشكرا

Book1.rar

[علي الشيخ]

السلام عليكم

أتفضل أخي شوف الملف المرفق وبالنسبة للأكواد في الملف

 

الكود التالي في ThisworkBook

 

الكود التالي يعمل على إضافة القائمة لكليك يمين في ملف الإكسل المحدد

ولكي يتم الإضافة لكل ملفات الإكسل شوف الكود اللي في نهاية الرد

Private Sub Workbook_Activate()
Call AddToCellMenu
End Sub

Private Sub Workbook_Deactivate()
Call DeleteFromCellMenu
End Sub

ثم قم بإدارج موديول عادي وانسخ فيه الكود التالي

الكود يحتوي على 3 ماكرو كل واحد يعمل على تغيير حالة الحروف في باللغة الإنجليزية من حروف كبيرة إلى صغيرة إلى حسب الجملة A - a - Ali

Sub AddToCellMenu()
Dim ContextMenu As CommandBar
Dim MySubMenu As CommandBarControl

'Delete the controls first to avoid duplicates
Call DeleteFromCellMenu

'Set ContextMenu to the Cell menu
Set ContextMenu = Application.CommandBars("Cell")

'Add one built-in button(Save = 3)to the cell menu
ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1

'Add one custom button to the Cell 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 custom menu 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 seperator to the Cell menu
ContextMenu.Controls(4).BeginGroup = True
End Sub



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

'Set ContextMenu to the Cell menu
Set ContextMenu = Application.CommandBars("Cell")

'Delete 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

'Delete built-in Save button
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_Deactivate()
Call DeleteFromCellMenu

Book123.rar

تم تعديل مايو 30, 2015 بواسطه علي الشيخ

[ياسر خليل أبو البراء]

جزيت خيراً يا أخي الحبيب علي الشيخ على هذه الهدية القيمة

بارك الله لنا فيك وأدام عليك الله نعمه وأدام عليك الصحة والعافية

 

الأخ الكريم ابن الملك (البرنس)

فيه موضوع لي من فترة بهذا الخصوص على هذا الرابط اطلع عليه عله يفيدك

 

رابط الموضوع من هنا

 

تقبل مروري

[علي الشيخ]

ربنا يزيدك علم والله أستاذ ياسر ويجعلك زخرا للمنتدى

جزاك الله خيرا

[محمد حسن المحمد]

السلام عليكم أخي علي الشيخ المحترم

إجابة موفقة لموضوع رائع .همة عالية واجتهاد واضح 

أرجو أن يقوم فريق خبراء البرمجة العرب بتطوير برامج تضاهي برامج الأوفيس وليس فقط التعديل عليها

جزاكم الله خيراً ووفقكم إلى كل خير ..

..تقبل تحياتي....السلام عليكم ورحمة الله وبركاته.

..أخوكم أبو يوسف ....

[ياسر خليل أبو البراء]

أخي محمد حسن أبو يوسف

أحب أقولك فيه كتير جداً عندهم درجة عالية من الاحترافية ، لكن للأسف

مشكلتنا في الوطن العربي إننا لا نشكل فريق واحد .. بل كل يعمل بمفرده ... العمل الجماعي أفضل بكثير من العمل الفردي

كل منا له نقاط قوة ولو اجتمعت نقاط القوة في فريق واحد متعاون سيحقق المستحيل

وربنا ييسر أمور المسلمين

[أسامة البراوى]

شكرا للجميع

شكرا أستاذ على الشيخ

شكرا استاذ ياسر على الموضوع السابق

 

اضافة جميلة وممكن ان توفر الكثير من الجهد

تم تعديل مايو 30, 2015 بواسطه أسامة البراوى

[ابن الملك]

الاستاذ على الشيخ شكرا لردك السريع وأجابتك الشافية

 

أستاذ ياسر خليل ... بكل أمانة انا بحب كل تعليقاتك اللى حضرتك بتكتبها 

 

شكرا لمرور كل الاخوة الافاضل وشكرا لهذا المنتدى الكريم 

 

والسلام عليكم ورحمة الله وبركاتة .

[ابن الملك]

من ابن الملك الى السادة الافاضل .... حول

 

هل هناك طريقة لترتيب الاوامر دى أصلها أصبحت اول اختيار اول ما ادوس على كليك يمين 

هل من الممكن أن نقوم بترتيبها يعنهى تبقى فى الاخر مش فى الاول ...... حول 

 

من اسد الى فهد .... حول

[علي الشيخ]

السلام عليكم ورحمة الله

مرحبا أخي

في الكود اللي انا وضعته تقدر تتحكم في موضع الإضافة لكليك يمين من الجزئية التالية

  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 custom menu with three buttons
    Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3)

    With MySubMenu
        .Caption = "Case Menu"
        .Tag = "My_Cell_Control_Tag"

إذا أردت جعل الإضافة في نهاية القائمة فسوف نقوم بحذف من السطر الأول

, before:=2)

 وحذف من السطر الثامن

, before:=3)

 وكده هتظهر في نهاية القائمة

 

إذا أردت تغيير ترتيبها مثلا في المنتصف أو رقم 5 أو ما إلخ

 

فقط قم بتغيير الرقم من 3 إلى 10 أو 15  بدون أن تحذفهم في كل مرة تغيير فيها إضغط F5 وفي الشيت نفسه اضغط كليك يمين عشان تشوف المكان الجديد لها

يعني الحذف فقط لو أردت إنهم يظهروا تلقائيا في نهاية قائمة كليك يمين

[ابن الملك]

شكرا ليك كتير يا أ على

 

وشكرا لمرور كل السادة الافاضل  .

[ابن الملك]

الاساتذة الكرام فى منتدى اوفيسنا

 

هو ينفع اعمل قائمة منبقة من قائمة منبثقة 

 

الاستاذ على الشيخ .  حضرتك عملت Popup Menu > Lower > Upper

ممكن اعمل اختيار تانى من جوة Lower بمعنى

           

<<<< Class Menu

^{1- اختيار رقم 1}

^{2- أختيار رقم 2}

^{أ - أختيار  رقم 1 منبثق من أختيار رقم 2}

^{ب- أختيار رقم 2 منبثق من اختيار رقم 2}

^{ج - أختيار رقم 3 منبثق من اختيار رقم 3}

^{3- أختيار رقم 3}

^{4- أختيار رقم 4}

 

 

أنا طولت اوى معلش