Rightclick Menu in VBA Userform

hicksi

hicksi

Board Regular
Joined
Mar 5, 2012
Messages
203
I have a CommandButton defined that creates a report.
I want to do two different (related) things:
1: Define shift-keys so:
  • If no shift-key, the report is shown in preview
  • If the user Shift-clicks. the report is sent directly to the printer
  • If the user Ctrl-Clicks, the report is automatically saved to disk
  • Double-click, a new form is displayed that allows them to filter the data being reported
2: Provide a right-click that displays a popup that gives menu-access to those (and displays the shortcut keysets)

Some of it I have working (key-combinations), and I have some templates done to get the popup.

BUT...
I have seen some posts about using the CommandBars object which seems to be cleverer and doesn't need to access and intimately control low-level functions.
Anybody know of how to make all this work, and whether it is possible/probable to do this?
 
Sort by date Sort by votes
OOPS, sorry.
I want the TEXT to appear so that people know what the shortcut is, not to use the shortcut while the popup is displayed.
The " .ShortcutText =" isn't working (for me)

But you get your hug back
 
Upvote 0

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
hicksi said:
OOPS, sorry.
I want the TEXT to appear so that people know what the shortcut is, not to use the shortcut while the popup is displayed.
The " .ShortcutText =" isn't working (for me)

But you get your hug back
Click to expand...
I coudn't get the ShortcutText Property to work either but you could do it via the CommandBarButton Caption and Style Properties as follows :

(While we are on the subject, there is also a TooltipText Property where we could ideally display the shortcut text but it doesn't seem to work.)

VBA Code: 
With .Controls.Add(Type:=msoControlButton)
  .BeginGroup = True
  .Caption = "Click Button1  (Alt+B)"  '<=== This is the workaround.
  .FaceId = 71
  .Style = msoButtonIconAndCaption
  .TooltipText = "Alt+B"        '<=== This didn't work for me !!!!!!!!!!!!!


Note:
As I said in my previous post, the Alt key won't work as part of a shortcut combination for context menu (CommandBarPopup) items.

I have some code almost finished at home which forces the Alt key to work as part of a shortcut. I'll post the code later.
 
Upvote 0
Here is some code that does the following:

A- Adds a right-click menu to a userform.

B- The macros that are assigned to each control can be invoked with mouse click as well as with a specific shortcut key
( Alt + Accelerator key ) which you can set in code during the control creation. The SetShortCutKeys routine takes care of this... The ShortCut Text is set along with the control Caption.

C- Allows only navigation keys while the menu is shown.

Workbook Demo

The code uses a windows keyboard hook, but I made sure the code is stable even if an unhandled error occurs while the hook is installled.


1- API based code in a Standard Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long

    Private hHook As LongPtr
#Else
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
    
    Private hHook As Long
#End If
    
Private oShortCutKeysCollection As Collection
Private Const sPopUpName As String = "MyPopUpMenu"


Public Sub DisplayPopUp(ByVal UF As Object)

    'Disable ESC key when UserForm is Modeless to avoid potential crashing.
     If IsWindowEnabled(Application.hwnd) Then
        EnableESCKey(UF) = False
    End If
    Call SetKeyboardHook
    Call CreateDisplayPopUpMenu

End Sub


Public Sub CleanUp(ByVal UF As Object)

    If IsWindowEnabled(Application.hwnd) = 0 Then
        EnableESCKey(UF) = True
    End If
    Call SetKeyboardHook(False)
    Call RemoveProp(Application.hwnd, "hHook")
    Set oShortCutKeysCollection = Nothing

End Sub

    
    
'_____________________________________Private Routines_________________________________________________

Private Property Let EnableESCKey(ByVal UF As Object, ByVal bEnable As Boolean)

    Const VK_ESCAPE = &H1B

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
    
    Call IUnknown_GetWindow(UF, VarPtr(hwnd))

    If bEnable = False Then
        Call RegisterHotKey(hwnd, &HBFFF&, 0, VK_ESCAPE)
    Else
        Call UnregisterHotKey(hwnd, &HBFFF&)
    End If

End Property


Private Sub SetKeyboardHook(Optional ByVal bSet As Boolean = True)

    Const WH_KEYBOARD = 2

     Call UnhookWindowsHookEx(GetProp(Application.hwnd, "hHook")): hHook = 0
    
    If bSet Then
        If hHook = 0 Then
            hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, 0, GetCurrentThreadId)
                Call SetProp(Application.hwnd, "hHook", hHook)
        End If
    End If

End Sub


#If Win64 Then
Private Function KeyboardProc(ByVal ncode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
    Dim lKeyVCode As LongLong
#Else
Private Function KeyboardProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lKeyVCode As Long
#End If

    Const HC_ACTION = 0
    Const VK_MENU = &H12
    Const VK_ESCAPE = &H1B
    Const VK_SPACE = &H20
    Const VK_PRIOR = &H21
    Const VK_NEXT = &H22
    Const VK_END = &H23
    Const VK_HOME = &H24
    Const VK_UP = &H26
    Const VK_DOWN = &H28
    Const VK_LEFT = &H25
    Const VK_RIGHT = &H27
    Const VK_RETURN = &HD
    
    Dim vAllowedKeys  As Variant, oTemp As CommandBarButton

    If hHook = 0 Then
        'Important safety mesure !! :-
        'Remove keyboard hook here and get out in case of an unhandled error.
        Call SetKeyboardHook(False): Exit Function
    End If
 
    vAllowedKeys = Array(VK_ESCAPE, VK_PRIOR, VK_NEXT, VK_END, VK_HOME, _
                            VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_RETURN)

    If ncode = HC_ACTION Then
    
        lKeyVCode = wParam
        If lParam And (2 ^ 29) Then  '29 'alt key' bit of lParam set.
            On Error Resume Next
                Set oTemp = oShortCutKeysCollection(VK_MENU & "||" & lKeyVCode)
            On Error GoTo 0
            If Not oTemp Is Nothing Then
                Call SetKeyboardHook(False)
                Exit Function
            End If
        End If
        
        If Not IsError((Application.Match(wParam, vAllowedKeys, 0))) Then
            Call SetKeyboardHook
            Exit Function
        End If
        
        KeyboardProc = 1
        Exit Function
 
    End If

    KeyboardProc = CallNextHookEx(hHook, ncode, wParam, lParam)
    
End Function


Private Sub SetShortCutKeys(ByVal MenuItem As Object, ByVal ModifierKey As Long, ByVal AcceleratorKey As Long)

    If oShortCutKeysCollection Is Nothing Then
        Set oShortCutKeysCollection = New Collection
    End If
    oShortCutKeysCollection.Add MenuItem, ModifierKey & "||" & AcceleratorKey

End Sub


Private Sub CreateDisplayPopUpMenu()

    Dim oButton As CommandBarButton, oPopUpMenu   As CommandBarPopup    
    
    Set oShortCutKeysCollection = Nothing
    
    On Error Resume Next
        Application.CommandBars(sPopUpName).Delete
    On Error GoTo 0
    
    With Application.CommandBars.Add(Name:=sPopUpName, Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
        
        Set oButton = .Controls.Add(Type:=msoControlButton)
        With oButton
        
            .BeginGroup = True
            .Caption = "&Button1  (Alt+B)"
            .Tag = .Caption
            Call SetShortCutKeys(oButton, vbKeyMenu, vbKeyB)  '<== Assign SortCutKeys here.
            .FaceId = 71
            .Style = msoButtonIconAndCaption
            .OnAction = "'OnActionMacro " & Chr(34) & .Caption & Chr(34) & "'"
        End With
        
        Set oButton = .Controls.Add(Type:=msoControlButton)
        With oButton
            .BeginGroup = True
            .Caption = "B&utton2  (Alt+U)"
              .Tag = .Caption
            Call SetShortCutKeys(oButton, vbKeyMenu, vbKeyU)  '<== Assign SortCutKeys here.
            .FaceId = 72
            .Style = msoButtonIconAndCaption
            .OnAction = "'OnActionMacro " & Chr(34) & .Caption & Chr(34) & "'"
        End With
        
        Set oButton = .Controls.Add(Type:=msoControlButton)
        With oButton
            .BeginGroup = True
            .Caption = "Bu&tton3  (Alt+T)"
              .Tag = .Caption
            SetShortCutKeys oButton, vbKeyMenu, vbKeyT  '<== Assign SortCutKeys here.
            .FaceId = 73
            .Style = msoButtonIconAndCaption
            .OnAction = "'OnActionMacro " & Chr(34) & .Caption & Chr(34) & "'"
        End With
        
        Set oPopUpMenu = .Controls.Add(Type:=msoControlPopup)
        With oPopUpMenu
            .Caption = "My Special Menu"
            .Tag = .Caption
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Butt&on1 in menu  (Alt+O)"
                .Tag = .Caption
                SetShortCutKeys oButton, vbKeyMenu, vbKeyO  '<== Assign SortCutKeys here.
                .FaceId = 71
                .OnAction = "'OnActionMacro " & Chr(34) & .Caption & Chr(34) & "'"
            End With
        End With
        
    End With
    
    On Error Resume Next
        Application.CommandBars(sPopUpName).ShowPopup
    On Error GoTo 0
    
End Sub


Sub OnActionMacro(Optional ByVal ButtonCaption As String)

    Dim sTrimedCaption As String
 
    sTrimedCaption = CommandBars.FindControl(Tag:=ButtonCaption).Caption
    sTrimedCaption = Application.Trim(Replace(Left(sTrimedCaption, InStr(1, sTrimedCaption, "(") - 1), "&", ""))
    
    MsgBox "You invoked: '" & sTrimedCaption & "'", vbInformation
    
End Sub




2- Code Usage in the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    If Button = 2 Then
        Call DisplayPopUp(Me)
    End If

End Sub

Private Sub UserForm_Terminate()

    Call CleanUp(Me)

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Forced to discard digital signature after opening and immediately saving an Macro-Enabled Excel file
Replies
0
Views
90
JDCreate
J
Knockoutpie
  • Solved
VBA Message box to popup and allow user to work within the sheet, upon closing start the code again
Replies
6
Views
511
Knockoutpie
Knockoutpie
S
  • Question
VBA import of an IQY file without prompt
Replies
4
Views
360
John_w
J
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
304
huiettcm
H
O
  • Solved
Add Image Button
Replies
4
Views
875
Domenic
D

Forum statistics

Threads
1,215,018
Messages
6,122,703
Members
449,093
Latest member
Mnur

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top