Printable View
Is there a way to set a keypress shortcut to display the menu? Even if it has the name "Menu" at the top of the menu. :yesCode:Dim CmdBar as CommandBar
Set CmdBar = CommandBars.Add(Name:="Roster", Position:=msoBarPopup, Temporary:=False)With CmdBar
.Controls.Add Type:=msoControlButton
.Controls(1).Caption = "&Clear Completely"
.Controls(1).OnAction = "ClearCompletely"
.Controls.Add Type:=msoControlButton
...
.
Here is an example to go by ...
In the ThisWorkbook Module, paste this :
Code:Option Explicit
Private Sub Workbook_Open()
Application.OnKey "a", "mkemenu" 'makemenu is the name of the macro that will be run when the key "a" is pressed.
End Sub
Paste this into a Routine Module :
The name of the macro can be anything you want, so long as the macro name and the reference to the name in ThisWorkbook is the same.Code:Option Explicit
Sub mkemenu()
MsgBox "Hi"
End Sub
The key can be anything you want as well. Instead of using Application.OnKey "a" ... you could use any other letter.
To find out more, do a 'google search' for : VBA OnKey
Thanks.
Doesn't work with a userform without a lot of work. (I have 120 comboboxes created at runtime.) :( It is bad enough that the user must right-click on the form itself.
.
Not certain I completely understand.
The context menu is for use while filling in a userform. Onkey doesn't work in this case. And with runtime created controls on the form, unless I create a class, I cannot make them respond to KeyDown.
.
Here is a sample UserForm Menu. It display the menu constantly but hopefully it is something you can use :
Code:Option Base 1
Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private xOffset As Single
Private yOffset As Single
Private Sub DisplayPopUp(ByVal idx As Byte)
Application.CommandBars("PopUpCb" & idx).ShowPopup xPos(idx), yPos
End Sub
Private Sub Button_U1_Click()
Call Menus_CheckBox(True)
End Sub
Private Sub Menus_CheckBox(Coché As Boolean)
Dim Ctl As Control
For Each Ctl In Me.Controls
If Left(Ctl.Name, 8) = "CheckBox" Then Ctl.Value = Coché
Next Ctl
End Sub
Private Sub ComboBox1_Change()
With ComboBox1
If .ListIndex = 0 Then [a1] = "un machin"
If .ListIndex = 1 Then [a1] = "un bidule"
If .ListIndex = 2 Then [a1] = "une chouette"
End With
End Sub
Private Sub lbl1_Click()
Call lblStyle(2, "1000")
DisplayPopUp 1
End Sub
Private Sub lbl1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "1000")
Call lblStyle(0, "1000")
End Sub
Private Sub lbl2_Click()
Call lblStyle(2, "0100")
DisplayPopUp 2
End Sub
Private Sub lbl2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "0100")
Call lblStyle(0, "0100")
End Sub
Private Sub lbl3_Click()
Call lblStyle(2, "0010")
DisplayPopUp 3
End Sub
Private Sub lbl3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "0010")
Call lblStyle(0, "0010")
End Sub
Private Sub lbl4_Click()
Call lblStyle(2, "0001")
DisplayPopUp 4
End Sub
Private Sub lbl4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "0001")
Call lblStyle(0, "0001")
End Sub
' 0-Flat / 1-Raised / 2-Sunken / 3-Etched
Sub lblStyle(look As Byte, Optional Info As String = "0000")
Dim i As Byte
For i = 1 To Len(Info)
If Mid(Info, i, 1) = 0 Then
Me.Controls("lbl" & i).Font.Bold = False
Me.Controls("lbl" & i).SpecialEffect = 0
Else
Me.Controls("lbl" & i).Font.Bold = True
Me.Controls("lbl" & i).SpecialEffect = look
End If
Next i
End Sub
Sub CreatePopUp(ByVal idx As Integer)
' CbPopUp() = niveaux d'imbrication
Dim cb As CommandBar, CbPopup(2) As CommandBarPopup, noMenu As String
Call DeletePopUp("PopUpCb" & idx)
noMenu = "'MacroName""" & idx
Set cb = CommandBars.Add("PopUpCb" & idx, msoBarPopup, False, True)
Select Case idx
Case 1
Call AddItemInMenu(cb, Range("a1").Value, 212, noMenu & "01""'")
Call AddItemInMenu(cb, "&Sauvegarder", 3, noMenu & "02""'")
Call AddItemInMenu(cb, "&Quitter", 1, noMenu & "03""'", True)
Case 2
Call AddItemInMenu(cb, "&Nouvelle", 18, noMenu & "01""'")
Call AddItemInMenu(cb, "&Existante", 23, noMenu & "02""'")
Call AddItemInMenu(cb, "&Réceptions", 109, noMenu & "03""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "Ed&itions"
CbPopup(1).BeginGroup = True
Call AddItemInMenu(CbPopup(1), "Cdes à &relancer", 4, noMenu & "04""'")
Call AddItemInMenu(CbPopup(1), "Cdes non &soldées", 4, noMenu & "05""'")
Call AddItemInMenu(cb, "&Total Achats", 283, noMenu & "06""'", True)
Call AddItemInMenu(cb, "A&purement", 67, noMenu & "07""'")
Case 3
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "A&rticles"
Call AddItemInMenu(CbPopup(1), "Fic&hes", 212, noMenu & "01""'")
Call AddItemInMenu(CbPopup(1), "&Utilisations", 140, noMenu & "02""'")
Call AddItemInMenu(CbPopup(1), "&Remplacement", 564, noMenu & "03""'")
Call AddItemInMenu(CbPopup(1), "&Liste des...", 4, noMenu & "04""'")
Call AddItemInMenu(CbPopup(1), "Calcul des c&oûts", 283, noMenu & "05""'")
Set CbPopup(2) = CbPopup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(2).Caption = "Fa&milles"
CbPopup(2).BeginGroup = True
Call AddItemInMenu(CbPopup(2), "&Fiches", 212, noMenu & "06""'")
Call AddItemInMenu(CbPopup(2), "Li&ste des...", 4, noMenu & "07""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "&Fournisseurs"
Call AddItemInMenu(CbPopup(1), "Fic&hes", 212, noMenu & "08""'")
Call AddItemInMenu(CbPopup(1), "Liste &des...", 4, noMenu & "09""'")
Call AddItemInMenu(CbPopup(1), "&Qualité...", 4, noMenu & "10""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "Four&nitures"
Call AddItemInMenu(CbPopup(1), "F&iches", 212, noMenu & "11""'")
Call AddItemInMenu(CbPopup(1), "Lis&te des...", 4, noMenu & "12""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "&Nomenclatures"
Call AddItemInMenu(CbPopup(1), "Co&nsultation", 109, noMenu & "13""'")
Call AddItemInMenu(CbPopup(1), "&Modif / Création / Sup.", 212, noMenu & "14""'")
Call AddItemInMenu(CbPopup(1), "&Historique modifs", 172, noMenu & "15""'")
Call AddItemInMenu(CbPopup(1), "&Import CAO", 524, noMenu & "16""'")
Call AddItemInMenu(CbPopup(1), "&Export CAO", 525, noMenu & "17""'")
Set CbPopup(2) = CbPopup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(2).Caption = "Editi&ons"
CbPopup(2).BeginGroup = True
Call AddItemInMenu(CbPopup(2), "&Quantifiée", 4, noMenu & "18""'")
Call AddItemInMenu(CbPopup(2), "Cumu&lée", 4, noMenu & "19""'")
Call AddItemInMenu(CbPopup(2), "Arbore&scente", 4, noMenu & "20""'")
Call AddItemInMenu(CbPopup(2), "&Liste des...", 4, noMenu & "21""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "&Données"
Call AddItemInMenu(CbPopup(1), "Cours des de&vises", 283, noMenu & "22""'")
Call AddItemInMenu(CbPopup(1), "&Imputations comptables", 195, noMenu & "23""'")
Call AddItemInMenu(CbPopup(1), "Im&putations analytiques", 303, noMenu & "24""'")
Call AddItemInMenu(CbPopup(1), "&Unités de mesure", 548, noMenu & "25""'")
Call AddItemInMenu(CbPopup(1), "&Conditions paiement", 384, noMenu & "26""'")
Call AddItemInMenu(CbPopup(1), "Coe&ff. Prix vente", 50, noMenu & "27""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "Stoc&ks"
Call AddItemInMenu(CbPopup(1), "&Entrées / Sorties", 212, noMenu & "28""'")
Call AddItemInMenu(CbPopup(1), "&Historique Trs", 172, noMenu & "29""'")
Case 4
Call AddItemInMenu(cb, "A&ide", 983, noMenu & "01""'")
Call AddItemInMenu(cb, "A pr&opos", 487, noMenu & "02""'")
End Select
Set CbPopup(1) = Nothing: Set CbPopup(2) = Nothing: Set cb = Nothing
End Sub
Private Function xPos(ByVal nb As Byte) As Single
xPos = (Me.Left + xOffset + Me.Controls("lbl" & nb).Left) * 4 / 3
End Function
Private Function yPos() As Single
yPos = (Me.Top + yOffset) * 4 / 3
End Function
Private Sub AddItemInMenu(CbControl As Object, TitleCaption As String, NoFaceId As Integer, WhenAction As String, Optional NewGroup As Boolean = False)
With CbControl.Controls.Add(msoControlButton, 1, , , True)
.BeginGroup = NewGroup
.Caption = TitleCaption
.Style = msoButtonIconAndCaption
.FaceId = NoFaceId
.OnAction = ThisWorkbook.Name & "!" & WhenAction & ""
End With
End Sub
Private Sub DeletePopUp(ByVal PopUpCbName As String)
On Error Resume Next
CommandBars(PopUpCbName).Delete
End Sub
Private Sub UserForm_Activate()
ComboBox1.AddItem "machin"
ComboBox1.AddItem "bidule"
ComboBox1.AddItem "chouette"
End Sub
Private Sub UserForm_Initialize()
Const pLbl As Byte = 3 ' Top des labels Menus
Const hLbl As Byte = 14 ' Hauteur des labels Menus
Dim i As Byte
For i = 1 To 4
Me.Controls("lbl" & i).Height = hLbl
Me.Controls("lbl" & i).Top = pLbl
Call CreatePopUp(i)
Next i
xOffset = (Me.Width - Me.InsideWidth) / 2
yOffset = Me.Height - Me.InsideHeight - xOffset + hLbl + pLbl
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call lblStyle(0, "0000")
End Sub
Something to look at.
Dear Logit,
Your Menu is Awesome its very useful shall i get in English version of the menu list.
.
I don't have a translated version. If you go to Google and select the TRANSLATION option, you can translate the words there.
Hope that helps.
Thank Logit :bow: