Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
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
2- UserForm Code
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 Function2- 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
