Consulting

Results 1 to 11 of 11

Thread: Have a shortcut key to command bar

  1. #1
    VBAX Regular
    Joined
    Jul 2018
    Posts
    11
    Location

    Have a shortcut key to command bar

    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
       ...
    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.

  2. #2
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    Here is an example to go by ...

    In the ThisWorkbook Module, paste this :

    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 :

    Option Explicit
    
    
    Sub mkemenu()
    MsgBox "Hi"
    End Sub
    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.

    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
    Attached Files Attached Files

  3. #3
    VBAX Regular
    Joined
    Jul 2018
    Posts
    11
    Location
    Thanks.

  4. #4
    VBAX Regular
    Joined
    Jul 2018
    Posts
    11
    Location
    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.

  5. #5
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    Not certain I completely understand.

  6. #6
    VBAX Regular
    Joined
    Jul 2018
    Posts
    11
    Location
    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.

  7. #7
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    Here is a sample UserForm Menu. It display the menu constantly but hopefully it is something you can use :

    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
    Attached Files Attached Files

  8. #8
    VBAX Regular
    Joined
    Jul 2018
    Posts
    11
    Location
    Something to look at.

  9. #9
    Dear Logit,

    Your Menu is Awesome its very useful shall i get in English version of the menu list.

  10. #10
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    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.

  11. #11
    Thank Logit

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •