Adding a Menu system to UserForms

Jaafar Tribak · Oct 6, 2021

Hi forum,

Workbook Example

I have been playing around with this little vba project and thought I would post it here.

Basically, the code creates a full menu system for (MODAL) userforms (up to 10 entries per menu) based on a table in a worksheet.

PREVIEW

The menus are indexed in the first column of the worksheet table and follow the the following format logic (See workbook example):
1
1.1
1.2
1.2.1
1.2.2
1.2.3
2
2.1
2.2
2.3
and so on.

The second column in the worksheet table holds the menu item caption, while the third column holds an optional icon (ICO,ANI,BMP or a FACE_ID #) and the last column is for the icon size in pixels.

Limitations:
Only works with MODAL userforms.... and only with one userform at a time.
Normally, in order to be able to respond to menu mouse clicks, the userform must be subclassed so we can intercept the WM_COMMAND msg. I have taken a different approach by using a WH_GETMESSAGE hook combined with a WH_CALLWNDPROC hook. This is so that we minimize the chances of crashing should an unhandled error occur.
I added an intentional raise error test button in the test- userform to verify that excel doesn't crash... The only exception is a compiled error inside the MouseMove event.
Still, I would advise to have propper error handling.

1- Code in a Standard Module

VBA Code:

Option Explicit

Private Enum IMAGE_TYPE
    ICO
    Bmp
    ANI
    'https://bettersolutions.com/vba/ribbon/face-ids-2003.htm
    FACE_ID
End Enum

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    #If Win64 Then
        hSubMenu As LongLong
        hbmpChecked As LongLong
        hbmpUnchecked As LongLong
        dwItemData As LongLong
        dwTypeData As String
        cch As Long
        '#if(WINVER >= 0x0500)
        hbmpItem As LongLong
        '#endif /* WINVER >= 0x0500 */
    #Else
        hSubMenu As Long
        hbmpChecked As Long
        hbmpUnchecked As Long
        dwItemData As Long
        dwTypeData As String
        cch As Long
        '#if(WINVER >= 0x0500)
        hbmpItem As Long
        '#endif /* WINVER >= 0x0500 */
    #End If
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
        hPic As Long
        hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type Msg
    #If Win64 Then
        hWnd As LongLong
        Message As Long
        wParam As LongLong
        lParam As LongLong
    #Else
        hWnd As Long
        Message As Long
        wParam As Long
        lParam As Long
    #End If
    time As Long
    pt As POINTAPI
End Type

Private Type CWPSTRUCT
    #If Win64 Then
        lParam As LongLong
        wParam As LongLong
        Message As Long
        hWnd As LongLong
    #Else
        lParam As Long
        wParam As Long
        Message As Long
        hWnd As Long
    #End If
End Type

'GDI+
Private Type GDIP_STARTUPINPUT
   GdiplusVersion As Long
  #If Win64 Then
        DebugEventCallback As LongLong
        SuppressBackgroundThread As LongLong
  #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
  #End If
   SuppressExternalCodecs As Long
End Type

#If VBA7 Then

    #If Win64 Then
        Private Declare PtrSafe Function MenuItemFromPoint Lib "user32" (ByVal hWnd As LongPtr, ByVal hMenu As LongPtr, ByVal ptScreen As LongLong) As Long
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function MenuItemFromPoint Lib "user32" (ByVal hWnd As LongPtr, ByVal hMenu As LongPtr, ByVal ptScreenX As Long, ByVal ptScreenY As Long) As Long
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetMenu Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetMenu Lib "user32" (ByVal hWnd As LongPtr, ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function CreateMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function DeleteMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare PtrSafe Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
    Private Declare PtrSafe Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As LongPtr, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
    Private Declare PtrSafe Function EnableMenuItemAPI Lib "user32" Alias "EnableMenuItem" (ByVal hMenu As LongPtr, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
    Private Declare PtrSafe Function GetMenuItemIDAPI Lib "user32" Alias "GetMenuItemID" (ByVal hMenu As LongPtr, ByVal nPos As Long) As Long
    Private Declare PtrSafe Function GetMenuItemCountAPI Lib "user32" Alias "GetMenuItemCount" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function DrawIconEx Lib "user32" (ByVal hDC As LongPtr, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As LongPtr, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As LongPtr, ByVal diFlags As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    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 GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GDIP_STARTUPINPUT, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateHICONFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, ByRef hbmReturn As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As LongPtr, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As LongPtr, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHICON Lib "gdiplus" (ByVal hIcon As LongPtr, ByRef hBitmap As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hUF As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hUF As LongPtr, ByVal nIDEvent As LongPtr) As Long
   
    Private hForm As LongPtr, hFormMenu As LongPtr, hMen As LongPtr

#Else

    Private Declare Function MenuItemFromPoint Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long, ByVal ptScreenX As Long, ByVal ptScreenY As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
    Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As Long
    Private Declare Function CreateMenu Lib "user32" () As Long
    Private Declare Function CreatePopupMenu Lib "user32" () As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
    Private Declare Function EnableMenuItemAPI Lib "user32" Alias "EnableMenuItem" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
    Private Declare Function GetMenuItemIDAPI Lib "user32" Alias "GetMenuItemID" (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Private Declare Function GetMenuItemCountAPI Lib "user32" Alias "GetMenuItemCount" (ByVal hMenu As Long) As Long
    Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    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 UnhookWindowsHookEx Lib "user32" (ByVal hHook 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 GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GDIP_STARTUPINPUT, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
    Private Declare Function GdipCreateHICONFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, ByRef hbmReturn As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
    Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long
    Private Declare Function GdipCreateBitmapFromHICON Lib "gdiplus" (ByVal hIcon As Long, ByRef hBitmap As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hUF As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hUF As Long, ByVal nIDEvent As Long) As Long
   
    Private hForm As Long, hFormMenu As Long, hMen As Long

#End If

Private BMPsCollection As Collection, MenusCollection As Collection
Private bMenuExpanded As Boolean, TotalMenuItems As Long
Private oForm As Object
Private MenItemID As String, MenItemCaption As String, MenItemPos As Long
Private ClickMacroName As String, MouseMoveMacroName As String



Public Sub AddMenu( _
    ByVal Form As Object, _
    ByVal SourceData As Range, _
    ByVal MouseClickEvent As String, _
    ByVal MouseMoveEvent As String _
   )

    Const MFS_POPUP = &H10&
    Const MFS_STRING = &H0&
    Const MIIM_ID = &H2
    Const MIIM_DATA = &H20
    Const MIIM_BITMAP = &H80
    Const MF_BYCOMMAND = &H0&
    Const MF_BYPOSITION = &H400&
    Const IMAGE_ICON = 1
    Const IMAGE_BITMAP = 0
    Const LR_LOADFROMFILE = &H10

    #If Win64 Then
        Dim hParentMenu As LongLong
        Dim hNewMenu As LongLong
        Dim hTmpImgPtr As LongLong
        Dim hImage As LongLong
    #Else
        Dim hParentMenu As Long
        Dim hNewMenu As Long
        Dim hTmpImgPtr As Long
        Dim hImage As Long
    #End If

    Dim ImgType As IMAGE_TYPE
    Dim MII As MENUITEMINFO
    Dim oStdPic As StdPicture
    Dim iAtom_ID As Integer
    Dim Cell As Range
    Dim MenuLevel As Long, NextLevel As Long
    Dim Caption As String
    Dim ImagePathOrFaceID As String
    Dim ImgSize As Long
    Dim TmpImagePathName As String
    Dim lCount As Long
    Dim StateFlags As Long
         
    Set MenusCollection = Nothing
    TotalMenuItems = 0
    bMenuExpanded = False
   
    Set oForm = Form
    ClickMacroName = MouseClickEvent
    MouseMoveMacroName = MouseMoveEvent
   
    Call IUnknown_GetWindow(Form, VarPtr(hForm))
    hFormMenu = CreateMenu
    Call SetMenu(hForm, hFormMenu)
    StateFlags = MIIM_ID Or MIIM_DATA

    For Each Cell In SourceData.Columns(1).Cells
   
        If MenusCollection Is Nothing Then
            Set MenusCollection = New Collection
        End If

        MenuLevel = Len(Replace(Cell.Text, ".", ""))
        NextLevel = Len(Replace(Cell.Offset(1).Text, ".", ""))
       
        If Not IsEmpty(Cell) Then
            Caption = Cell.Offset(, 1).Text
            ImagePathOrFaceID = FindImagePath(Cell.Offset(, 2).Text)
            ImgSize = Val(Cell.Offset(, 3).Text)
            If ImgSize < 16 Then ImgSize = 16
           
            If Len(ImagePathOrFaceID) Then
           
                If UCase(Right(ImagePathOrFaceID, 4)) = ".BMP" Then
                    ImgType = Bmp
                ElseIf UCase(Right(ImagePathOrFaceID, 4)) = ".ANI" Then
                    ImgType = ANI
                ElseIf UCase(Right(ImagePathOrFaceID, 4)) = ".ICO" Then
                    ImgType = ICO
                ElseIf Val(ImagePathOrFaceID) Then
                    ImgType = FACE_ID
                End If
               
                Select Case ImgType
                    Case Bmp
                        hImage = LoadImage(0, ImagePathOrFaceID, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
                        hTmpImgPtr = BitmapToIcon(hImage, ImgSize)
                        hTmpImgPtr = IconToBitmap(hTmpImgPtr, ImgType, ImgSize)
                    Case ICO, ANI
                        hImage = LoadImage(0, ImagePathOrFaceID, IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
                        hTmpImgPtr = IconToBitmap(hImage, ImgType, ImgSize)
                    Case FACE_ID
                        If Len(ImagePathOrFaceID) Then
                            Set oStdPic = PicFromBmp(CLng(ImagePathOrFaceID))
                            If Not oStdPic Is Nothing Then
                                TmpImagePathName = Environ("TEMP") & Application.PathSeparator & "TempFaceID.bmp"
                                Call stdole.SavePicture(oStdPic, TmpImagePathName)
                                hImage = LoadImage(0, TmpImagePathName, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
                                hTmpImgPtr = BitmapToIcon(hImage, ImgSize)
                                hTmpImgPtr = IconToBitmap(hTmpImgPtr, ImgType, ImgSize)
                                Call Kill(TmpImagePathName)
                            End If
                        End If
                End Select
                Call DeleteObject(hImage)
                Set oStdPic = Nothing
            Else
                    hTmpImgPtr = 0
            End If
           
            If hTmpImgPtr Then
                StateFlags = StateFlags Or MIIM_BITMAP
            End If
            If MenuLevel < NextLevel Then
                hNewMenu = CreateMenu
                MenusCollection.Add hNewMenu, CStr(Replace(Cell.Text, ".", ""))
                hParentMenu = GetParentMenu(Replace(Cell.Text, ".", ""))
                Call AppendMenu(hParentMenu, MFS_POPUP, hNewMenu, Caption)
                With MII
                    .cbSize = LenB(MII)
                    .fMask = StateFlags
                    .wID = lCount
                    iAtom_ID = GlobalAddAtom(hNewMenu & "||" & Replace(Caption, "&", "") & "||" & Cell.Text & "||" & lCount)
                    Call SetProp(hForm, "Atom", CLng(iAtom_ID))
                    .dwItemData = iAtom_ID
                    .hbmpItem = hTmpImgPtr
                    Call SetMenuItemInfo(hParentMenu, CLng(hNewMenu), MF_BYCOMMAND, MII)
                End With
            Else
                hParentMenu = GetParentMenu(Replace(Cell.Text, ".", ""))
                Call AppendMenu(hParentMenu, MFS_STRING, lCount, Caption)
                With MII
                    .cbSize = LenB(MII)
                    .fMask = StateFlags
                    .wID = lCount
                    iAtom_ID = GlobalAddAtom(hNewMenu & "||" & Replace(Caption, "&", "") & "||" & Cell.Text & "||" & lCount)
                    Call SetProp(hForm, "Atom", CLng(iAtom_ID))
                    .dwItemData = iAtom_ID
                    .hbmpItem = hTmpImgPtr
                    Call SetMenuItemInfo(hParentMenu, lCount, MF_BYCOMMAND, MII)
                End With
            End If
            lCount = lCount + 1
        End If
    Next Cell

    TotalMenuItems = lCount
    Call DrawMenuBar(hForm)
    Call SetHooks(hForm)

End Sub

Public Sub CleanUp(Optional ByVal Dummy As Boolean)

    Dim i As Long
   
    Call GlobalDeleteAtom(CInt(GetProp(hForm, "Atom")))
    Call RemoveProp(hForm, "Atom")
    Call RemoveHooks
   
    If Not BMPsCollection Is Nothing Then
        With BMPsCollection
            For i = .Count To 1 Step -1
                Call DeleteObject(.Item(i))
                .Remove i
            Next i
        End With
    End If
   
    Set BMPsCollection = Nothing
    Call DestroyMenu(hFormMenu)
   
End Sub

Public Sub EnableMenuItem(ByVal MenuItemPos As Long, ByVal bEnable As Boolean)
    Const MF_BYCOMMAND = &H0&
    Const MF_DISABLED = &H2
    Const MF_ENABLED = &H0
    Call EnableMenuItemAPI(hFormMenu, MenuItemPos, MF_BYCOMMAND + IIf(bEnable, MF_ENABLED, MF_DISABLED))
    Call DrawMenuBar(hForm)
End Sub

Public Sub DeleteMenuItem(ByVal MenuItemPos As Long)
    Const MF_BYCOMMAND = &H0&
    Call DeleteMenu(hFormMenu, MenuItemPos, MF_BYCOMMAND)
    Call DrawMenuBar(hForm)
End Sub

Public Function GetMenuItemCaptionFromItemPos(ByVal MenuItemPos As Long) As String
    Const MF_BYCOMMAND = &H0&
    Dim sBuffer  As String * 256, lRet As Long
    lRet = GetMenuString(hFormMenu, MenuItemPos, sBuffer, Len(sBuffer), MF_BYCOMMAND)
    GetMenuItemCaptionFromItemPos = Left(sBuffer, lRet)
End Function

Public Function GetMenuItemIDFromItemPos(ByVal MenuItemPos As Long) As String
    Const MF_BYCOMMAND = &H0&
    Const MIIM_DATA = &H20
    Dim MII As MENUITEMINFO
    Dim sBuffer  As String * 256, lRet As Long
    With MII
        .cbSize = LenB(MII)
        .fMask = MIIM_DATA
    End With
    Call GetMenuItemInfo(hFormMenu, MenuItemPos, MF_BYCOMMAND, MII)
    lRet = GlobalGetAtomName(CInt(MII.dwItemData), sBuffer, Len(sBuffer))
    GetMenuItemIDFromItemPos = Split(Left(sBuffer, lRet), "||")(2)
End Function

Public Function GetMenuItemsTotalCount() As Long
    GetMenuItemsTotalCount = TotalMenuItems
End Function

Public Function GetMenusCount() As Long
    GetMenusCount = MenusCollection.Count
End Function

Public Function GetMainMenusCount() As Long
    GetMainMenusCount = GetMenuItemCountAPI(GetMenu(hForm))    '
End Function

Public Function CAPTION_OF_MenuItemUnderMousePointer() As String

    Const MF_BYPOSITION = &H400&
    #If Win64 Then
        Dim hMenu As LongLong, hWinUnderMouse As LongLong
    #Else
        Dim hMenu As Long, hWinUnderMouse As Long
    #End If
    Dim sBuffer2  As String * 256, lRet2 As Long
    Dim tCurPos As POINTAPI, vKid As Variant, oIA As IAccessible
    Dim MenuPos As Long

    On Error Resume Next
   
    MenuPos = POS_OF_MenuItemFromPoint(hMenu)
    lRet2 = GetMenuString(hMenu, MenuPos, sBuffer2, Len(sBuffer2), MF_BYPOSITION)
   
    If Len(Replace(Left(sBuffer2, lRet2), "&", "")) Then
        CAPTION_OF_MenuItemUnderMousePointer = Replace(Left(sBuffer2, lRet2), "&", "")
    Else
        Call GetCursorPos(tCurPos)
        #If Win64 Then
            Dim Ptr As LongLong
            Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
            Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
             hWinUnderMouse = WindowFromPoint(Ptr)
        #Else
            Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
             hWinUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y)
        #End If
        If hWinUnderMouse <> hForm Then
            CAPTION_OF_MenuItemUnderMousePointer = oIA.accName(0&)
        End If
    End If

End Function

'
Public Function ID_OF_MenuItemUnderMousePointer() As String

  Const MIIM_DATA = &H20
  Const MF_BYPOSITION = &H400&

    #If Win64 Then
        Dim hMenu As LongLong
    #Else
        Dim hMenu As Long
    #End If
   
    Dim MII As MENUITEMINFO
    Dim MenuPos As Long
    Dim sBuffer  As String * 256, lRet As Long

    MenuPos = POS_OF_MenuItemFromPoint(hMenu)
    With MII
        .cbSize = LenB(MII)
        .fMask = MIIM_DATA
    End With
    Call GetMenuItemInfo(hMenu, MenuPos, MF_BYPOSITION, MII)
    lRet = GlobalGetAtomName(CInt(MII.dwItemData), sBuffer, Len(sBuffer))
    ID_OF_MenuItemUnderMousePointer = Split(Left(sBuffer, lRet), "||")(2)

End Function


Public Function POS_OF_MenuItemUnderMousePointer() As Long
   
    Dim tCurPos As POINTAPI
       Dim L  As Long, T As Long
 
    On Error Resume Next
 
    Dim vKid As Variant
    Dim oIA As IAccessible
    Dim lResult As Long
 
    Call GetCursorPos(tCurPos)
    #If Win64 Then
        Dim Ptr As LongLong
        Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
        Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
    #Else
        Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
    #End If

    POS_OF_MenuItemUnderMousePointer = vKid

End Function


Public Function IsMenuExpanded() As Boolean
    IsMenuExpanded = bMenuExpanded
End Function




'_______________________________________PRIVATE ROUTINES___________________________________________


#If Win64 Then
    Private Function GetParentMenu(ByVal CellText As String) As LongLong
#Else
    Private Function GetParentMenu(ByVal CellText As String) As Long
#End If

    On Error Resume Next
   
    Dim sParent As String
   
    If Len(CellText) Then
        If Len(CellText) = 1 Then
            GetParentMenu = hFormMenu
        Else
            sParent = Left(CellText, Len(CellText) - 1)
        End If
        GetParentMenu = MenusCollection(sParent)
    End If

End Function

#If Win64 Then
    Private Function POS_OF_MenuItemFromPoint(ByRef hMenu As LongLong) As Long
        Dim hWndMenu As LongLong, Ptr As LongLong
#Else
    Private Function POS_OF_MenuItemFromPoint(ByRef hMenu As Long) As Long
        Dim hWndMenu As Long
#End If

    Const MN_GETHMENU = &H1E1
    Dim tCurPos As POINTAPI
   
    hWndMenu = FindWindow("#32768", vbNullString)
    If hWndMenu Then
        Call GetCursorPos(tCurPos)
        hMenu = SendMessage(hWndMenu, MN_GETHMENU, 0, 0)
        #If Win64 Then
            Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
            POS_OF_MenuItemFromPoint = MenuItemFromPoint(0, hMenu, Ptr)
        #Else
            POS_OF_MenuItemFromPoint = MenuItemFromPoint(0, hMenu, tCurPos.X, tCurPos.Y)
        #End If
    End If

End Function

#If Win64 Then
    Private Sub SetHooks(ByVal hWnd As LongLong)
        Dim hHook1 As LongLong, hHook2 As LongLong
#Else
    Private Sub SetHooks(ByVal hWnd As Long)
        Dim hHook1 As Long, hHook2 As Long
#End If
 
    Const WH_GETMESSAGE = 3
    Const WH_CALLWNDPROC = 4
   
    Call RemoveHooks
   
    hHook1 = SetWindowsHookEx(WH_GETMESSAGE, AddressOf MenuProc, GetModuleHandle(vbNullString), _
        GetWindowThreadProcessId(Application.hWnd, 0))
   
    hHook2 = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf SafeExitHook, _
        GetModuleHandle(vbNullString), GetWindowThreadProcessId(Application.hWnd, 0))
   
    Call SetProp(hWnd, "Hook1", hHook1)
    Call SetProp(hWnd, "Hook2", hHook2)

End Sub

Private Sub RemoveHooks()
    Call UnhookWindowsHookEx(GetProp(hForm, "Hook1"))
    Call UnhookWindowsHookEx(GetProp(hForm, "Hook2"))
    Call RemoveProp(hForm, "Hook1")
    Call RemoveProp(hForm, "Hook2")
    Call KillTimer(hForm, 0)
End Sub


#If Win64 Then
    Private Function SafeExitHook( _
        ByVal ncode As Long, _
        ByVal wParam As LongLong, _
        lParam As CWPSTRUCT _
    ) As LongLong

#Else
    Private Function SafeExitHook( _
        ByVal ncode As Long, _
        ByVal wParam As Long, _
        lParam As CWPSTRUCT _
    ) As Long
#End If

    Const WM_CREATE = &H1
    Dim strClass As String * 256

    If lParam.Message = WM_CREATE Then
        strClass = Left(strClass, GetWindowText(lParam.hWnd, ByVal strClass, 256))
        If InStr(1, strClass, "Microsoft Visual Basic") Then
            Call RemoveHooks
            Debug.Print "hooks removed !!!"
        End If
    End If
 
    SafeExitHook = CallNextHookEx(GetProp(hForm, "Hook2"), ncode, wParam, ByVal lParam)
 
End Function


#If Win64 Then
    Private Function MenuProc( _
        ByVal ncode As Long, _
        ByVal wParam As LongLong, _
        lParam As Msg _
    ) As LongLong

        Dim hWndMenu As LongLong, hMnu As LongLong, hMenu As LongLong, Ptr As LongLong
#Else
    Private Function MenuProc( _
        ByVal ncode As Long, _
        ByVal wParam As Long, _
        lParam As Msg _
    ) As Long

        Dim hWndMenu As Long, hMnu As Long, hMenu As Long
#End If

    Const HC_ACTION = 0&
    Const WM_COMMAND = &H111
    Const WM_MOUSEMOVE = &H200
    Const MF_BYCOMMAND = &H0&
    Const MF_BYPOSITION = &H400&
    Const MIIM_ID = &H2
    Const MIIM_DATA = &H20
    Const MN_GETHMENU = &H1E1
   
    Static sPrevCaption  As String
    Static sCaption2 As String
    Static ID As Long

    Dim MII1 As MENUITEMINFO, MII2 As MENUITEMINFO
    Dim sBuffer  As String * 256, lRet As Long
    Dim sBuffer2  As String * 256, lRet2 As Long
    Dim sCaption As String, sMenItemID As String
    Dim MenuPos As Long
    Dim MaskFlags As Long
 
    On Error Resume Next
   
    If (ncode = HC_ACTION) Then
   
        MaskFlags = MIIM_ID Or 0 Or MIIM_DATA
        With MII1
            .cbSize = LenB(MII1)
            .fMask = MaskFlags
        End With
        Call GetMenuItemInfo(GetMenu(hForm), CLng(lParam.wParam), MF_BYCOMMAND, MII1)
        lRet = GlobalGetAtomName(CInt(MII1.dwItemData), sBuffer, Len(sBuffer))
        hMenu = Split(Left(sBuffer, lRet), "||")(0)
        sCaption = Split(Left(sBuffer, lRet), "||")(1)
        sMenItemID = Split(Left(sBuffer, lRet), "||")(2)
       
        If lParam.Message = WM_MOUSEMOVE Then
            hWndMenu = FindWindow("#32768", vbNullString)
            If hWndMenu Then
                bMenuExpanded = True
                hMnu = SendMessage(hWndMenu, MN_GETHMENU, 0, 0)
                #If Win64 Then
                    Call CopyMemory(Ptr, lParam.pt, LenB(lParam.pt))
                    MenuPos = MenuItemFromPoint(0, hMnu, Ptr)
               #Else
                    MenuPos = MenuItemFromPoint(0, hMnu, lParam.pt.X, lParam.pt.Y)
               #End If
                With MII2
                    .cbSize = LenB(MII2)
                    .fMask = MaskFlags
                End With
                Call GetMenuItemInfo(hMnu, MenuPos, MF_BYPOSITION, MII2)
                lRet2 = GetMenuString(hMnu, MenuPos, sBuffer2, Len(sBuffer2), MF_BYPOSITION)
                If sPrevCaption <> Replace(Left(sBuffer2, lRet2), "&", "") Then
                    Call RemoveHooks
                    sCaption2 = Replace(Left(sBuffer2, lRet2), "&", "")
                    ID = MII2.wID
                    CallByName oForm, MouseMoveMacroName, VbMethod, Replace(Left(sBuffer2, lRet2), "&", ""), MII2.wID
                    Call SetHooks(hForm)
                End If
            Else
                bMenuExpanded = False
            End If
        End If
        sPrevCaption = sCaption2
       
        If lParam.Message = WM_COMMAND Then
            Call RemoveHooks
            hMen = hMenu
            MenItemID = sMenItemID
            MenItemCaption = sCaption
            MenItemPos = MII1.wID
            Call SetTimer(hForm, 0, 0, AddressOf TimerProc)
        End If

    End If
   
    MenuProc = CallNextHookEx(GetProp(hForm, "Hook1"), ncode, wParam, ByVal lParam)
 
End Function

Private Sub TimerProc()
    Call KillTimer(hForm, 0)
    Call Application.OnTime(Now, "MouseClickEvent")
End Sub

Private Sub MouseClickEvent()
    CallByName oForm, ClickMacroName, VbMethod, hMen, MenItemID, MenItemCaption, MenItemPos
    Call SetHooks(hForm)
End Sub

Private Function FindImagePath(ByVal ImgPath As String) As String
    Dim sTemp As String
    Select Case True
        Case IsValidFaceID(ImgPath)
            FindImagePath = ImgPath
        Case Len(Dir(ImgPath))
            FindImagePath = ImgPath
        Case Len(ImgPath)
            sTemp = ThisWorkbook.Path & Application.PathSeparator & ImgPath
            On Error Resume Next
                If Len(Dir(sTemp)) Then
                    If Err.Number = 0 Then
                        FindImagePath = sTemp
                    End If
            On Error GoTo 0
            End If
    End Select
End Function

Private Function IsValidFaceID(ByVal FaceID As String) As Boolean
    On Error Resume Next
    IsValidFaceID = Not (Application.CommandBars.FindControl(ID:=CLng(FaceID)) Is Nothing)
End Function

#If Win64 Then
    Private Function PicFromBmp(ByVal FaceID As Long) As StdPicture
        Dim hBmpPtr As LongLong
#Else
    Private Function PicFromBmp(ByVal FaceID As Long) As StdPicture
        Dim hBmpPtr As Long
#End If

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = &H0&

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long
   
    On Error GoTo errHandler
   
    Application.CommandBars.FindControl(ID:=FaceID).CopyFace
    Call OpenClipboard(0)
    hBmpPtr = GetClipboardData(CF_BITMAP)
    hBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
   
    If hBmpPtr Then
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hBmpPtr
            .hPal = 0
        End With
        lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
        If lRet = S_OK Then
            Set PicFromBmp = IPic
        End If
    End If
   
errHandler:
    Call EmptyClipboard
    Call CloseClipboard
   
    If BMPsCollection Is Nothing Then _
            Set BMPsCollection = New Collection
            Call BMPsCollection.Add(hBmpPtr)
 
End Function


#If Win64 Then
    Private Function BitmapToIcon(ByVal Bmp As LongLong, ImageSize As Long) As LongLong
        Dim lBitmap As LongLong, lThumb As LongLong
#Else
    Private Function BitmapToIcon(ByVal Bmp As Long, ImageSize As Long) As Long
        Dim lBitmap As Long, lThumb As Long
#End If

    Const S_OK = 0&
    Dim tSI As GDIP_STARTUPINPUT
    Dim lRes As Long
    Dim lGDIP As Long
   
    On Error Resume Next
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI)
    If lRes = S_OK Then
        lRes = GdipCreateBitmapFromHBITMAP(Bmp, 0, lBitmap)
        If lRes = S_OK Then
            lRes = GdipGetImageThumbnail(lBitmap, ImageSize, ImageSize, lThumb, 0, 0)
            If lRes = S_OK Then
                lRes = GdipCreateHICONFromBitmap(lThumb, BitmapToIcon)
                Call GdipDisposeImage(lThumb)
            End If
            Call GdipDisposeImage(lBitmap)
        End If
        Call GdiplusShutdown(lGDIP)
    End If

End Function


#If Win64 Then
    Private Function IconToBitmap(ByVal hImage As LongLong, ByVal ImageType As IMAGE_TYPE, ByVal ImageSize As Long) As LongLong
        Dim hDC As LongLong, hCompatDc As LongLong
#Else
    Private Function IconToBitmap(ByVal hImage As Long, ByVal ImageType As IMAGE_TYPE, ByVal ImageSize As Long) As Long
        Dim hDC As Long, hCompatDc As Long
#End If

    Const TRANSPARENT = 1
    Const SM_CXMENUCHECK = 71
    Const ETO_OPAQUE = 2
    Const DI_NORMAL = &H3&
    Const COLOR_MENU = 4
   
    Dim RECT As RECT
   
    If BMPsCollection Is Nothing Then _
            Set BMPsCollection = New Collection
   
    If ImageSize = 0 Then _
            ImageSize = GetSystemMetrics(SM_CXMENUCHECK)
   
    hDC = GetDC(hForm)
    With RECT
        .Right = ImageSize
        .Bottom = ImageSize
        hCompatDc = CreateCompatibleDC(0)
        IconToBitmap = CreateCompatibleBitmap(hDC, .Right, .Bottom)
        Call SelectObject(hCompatDc, IconToBitmap)
        Call SetBkMode(hCompatDc, TRANSPARENT)
        Call SetBkColor(hCompatDc, GetSysColor(COLOR_MENU))
        Call ExtTextOut(hCompatDc, 0, 0, ETO_OPAQUE, RECT, vbNullString, 0, 0)
        Call DrawIconEx(hCompatDc, 0, 0, hImage, .Right, .Bottom, 0, 0, DI_NORMAL)
        Call DeleteDC(hCompatDc)
    End With
    Call ReleaseDC(hForm, hDC)
   
    Call BMPsCollection.Add(IconToBitmap)
   
End Function

2- UserForm Code

VBA Code:

Option Explicit


Private Sub UserForm_Activate()
    AddMenu Me, MenuSourceData.Range("A4:D36"), "MouseClickEvent", "MouseMoveEvent"
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call CleanUp
End Sub

Private Sub RaiseError_Test_Click()
    Err.Raise Number:=vbObjectError + 513, _
            Description:="Wooh !!!" & vbNewLine & "No GPF, No Application shut down !!" & _
            vbNewLine & vbNewLine & "Hooks safely released."
End Sub



'_________________________________ PUBLIC PSEUDO-EVENTS _________________________________________

#If Win64 Then
        Public Sub MouseClickEvent( _
        ByVal Menu As LongLong, _
        ByVal MenuItemID As String, _
        ByVal MenuItemCaption As String, _
        ByVal GlobalMenuItemPos As Long _
    )
#Else
        Public Sub MouseClickEvent( _
        ByVal Menu As Long, _
        ByVal MenuItemID As String, _
        ByVal MenuItemCaption As String, _
        ByVal GlobalMenuItemPos As Long _
    )
#End If

    Me.LblMenuItemCaption = ""
    Me.LblMenuItemID = ""
    Me.LblMenuItemPos = ""

    MsgBox "You clicked : " & vbNewLine & vbNewLine & _
                "Menu Handle : " & Menu & vbNewLine & _
                "Menu Item ID : " & MenuItemID & vbNewLine & _
                "Menu Item Caption : " & MenuItemCaption & vbNewLine & _
                "Menu Item Global Position : " & GlobalMenuItemPos

End Sub


Public Sub MouseMoveEvent( _
        ByVal MenuItemCaption As String, _
        ByVal GlobalMenuItemPos As Long _
    )
 
    '=================================================
    ' IMPORTANT NOTE:
    '
       'Compilation errors in this specific event routine will crash excel !!!!
       'Run-Time errors however are OK.
    '==================================================

        Me.LblMenuItemCaption = CAPTION_OF_MenuItemUnderMousePointer
        Me.LblMenuItemID = ID_OF_MenuItemUnderMousePointer
        Me.LblMenuItemPos = POS_OF_MenuItemUnderMousePointer
       
    ''You can also use the event arguments.

End Sub

MDYusuf · May 11, 2022

Jaafar Tribak said:
Two things :
1- You need to have the pictures/icon files in the same folder as that of the workbook.
2- You need to add the picture file name (without the file path) to the corresponding row in the 3rd worksheet table column titled : Menu Item Icon File Path (Or FACE_ID #)

Edit:
You can have the pictures/icon files in a different folder as long as you add the full file pathname to the table column.

Regards.

Hi Jaafar Tribak,

Is not working, please refer to the snapshot.

Kind Regards
MD Yusuf

MDYusuf · May 11, 2022

MDYusuf said:
Hi Jaafar Tribak,

Is not working, please refer to the snapshot.

MDYusuf said:

Let me know if i did wrongly the input.

Kind Regards
MD Yusuf

Jaafar Tribak · May 11, 2022

Looks correct to me.

Was the About.bmp file extension changed at any stage from a different file extension to .bmp ? If so, although it says it is a bmp file, it will not have a bmp format.

Try with other true bmp or ico files and see if that works for you.

John Peter · May 14, 2022

Jaafar Tribak said:
Hi @John Peter. Sorry for not replying sooner.

The menu event handlers should normally reside in the client module (ie: the UserForm Module) in keeping with the standard MS events calling convention.

True. The code I posted for Modal UserForms is not object oriented or event-Driven that's why I called them PSEUDO-Events . In order to make the code raise propper events I should have used a Class instead of a Standard module. (Similar to what I did in post#10 for Modelss UserForms).

With the Class approach, one could apply the menus to muliple Modal UserForms.

So ,to sum up. anyone wanting to add worksheet-based menu systems to multiple Modal UserForms , I suggest that thay try the code that I will be posting next and see if it works for them.

However, the burden of Error Handling (inside the event handlers) is on the user. This is because the code I am writing, subclasses the userforms and, although I am adding some background error trapping, any unhandled errors (inside the event handlers) will still crash excel badly. So, careful error handling is needed if you are going to use the code.

I will post the code later on when I finish it.

Regards.

Hi @Jaafar Tribak Thank you for this explanation. I managed to modify your code that it would do some specific actions when clicking each menu item, but I could not be able to insert a spacer or line between the items to make them as groups. As for my code in my question in Hi everyone, I have this vba code that creates a menu bar in an Excel userform But I want to trigger actions when I click the sub menus. ,I dismissed it even it very simple and I can make spacers in it, but it is useless since one can not do anything by clicking its items. I will be waiting for the code and thank you in advance.
My Regards.

Jaafar Tribak · May 14, 2022

I managed to modify your code that it would do some specific actions when clicking each menu item, but I could not be able to insert a spacer or line between the items to make them as groups

Check the update in post#38 where I added Line Separators to be able to organise items into groups.

,I dismissed it even it very simple and I can make spacers in it, but it is useless since one can not do anything by clicking its items. I will be waiting for the code and thank you in advance.

Adding the menus is easy. Trapping the user action like mouse hover , selecting and clicking menus is the diffcult part and requires extensive code.

Adding a Menu system to UserForms

Jaafar Tribak

Well-known Member

MDYusuf

New Member

Excel Facts

MDYusuf

New Member

Jaafar Tribak

Well-known Member

John Peter

New Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

Adding a Menu system to UserForms

Jaafar Tribak

Well-known Member

MDYusuf

New Member

Excel Facts

MDYusuf

New Member

Jaafar Tribak

Well-known Member

John Peter

New Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock