| '-------- Class: clsButtonMenu
Option Explicit
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 wwIDNewItem As Long, _
ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) _
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 ReleaseCapture Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As _
Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal _
hwnd As Long, lpTPMParams As TPMPARAMS) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, src As Any, ByVal length As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Const MF_POPUP = &H10&
Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_DISABLED = &H2&
Private Const MF_CHECKED = &H8&
Private Const MF_GRAYED = &H1&
Private Const BM_SETSTATE = &HF3
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_RIGHTALIGN = &H8&
Private Const TPM_TOPALIGN = &H0&
Private Const TPM_BOTTOMALIGN = &H20&
Private Const TPM_VERTICAL = &H40&
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TPMPARAMS
cbSize As Long
rcExclude As RECT
End Type
'Old layout for VB5
'Private Type VB_MENU
' nUnknown(0 To 48) As Long
' dwFlags As Long
' pNextMenu As Long
' pFirstItem As Long
' sName As String
' hMenu As Long
' wID As Integer
' wShortCut As Integer
'End Type
'Layout for VB6
Private Type VB_MENU
nUnknown(0 To 54) As Long
dwFlags As Long
pNextMenu As Long
pFirstItem As Long
nUnknown2(0 To 1) As Long
wID As Integer
wShortCut As Integer
End Type
Private Enum enumMenuFlags
flagChecked = 1
flagHidden = 2
flagDisabled = 4
flagLastItem = 256
End Enum
Public Enum enumSwIDe
swIDeTop
swIDeBottom
swIDeLeft
swIDeRight
End Enum
Private WithEvents m_cmdButton As CommandButton
Private m_frmParent As Form
Private m_mnuItem As Menu
Private m_swIDeDropDown As enumSwIDe
Private m_bEnabled As Boolean
Public Property Get Enabled() As Boolean
Enabled = m_bEnabled
End Property
Public Property Let Enabled(newEnabled As Boolean)
m_bEnabled = newEnabled
End Property
Public Property Get SwIDe() As enumSwIDe
SwIDe = m_swIDeDropDown
End Property
Public Property Let SwIDe(newSwIDe As enumSwIDe)
m_swIDeDropDown = newSwIDe
End Property
Public Property Get Button() As CommandButton
Set Button = m_cmdButton
End Property
Public Property Set Button(newButton As CommandButton)
Set m_cmdButton = newButton
End Property
Public Property Get Menu() As Menu
Set Menu = m_mnuItem
End Property
Public Property Set Menu(newMenu As Menu)
Set m_mnuItem = newMenu
End Property
Public Property Get Form() As Form
Set Form = m_frmParent
End Property
Public Property Set Form(newForm As Form)
Set m_frmParent = newForm
End Property
Private Function GetNextMenu(ByVal mnuItem As Menu) As Menu
Dim mnuType As VB_MENU
Dim mnuTemp As Menu
CopyMemory mnuType, ByVal ObjPtr(mnuItem), Len(mnuType)
If mnuType.pNextMenu <> 0 And (mnuType.dwFlags And flagLastItem) = 0 _
Then
CopyMemory mnuTemp, mnuType.pNextMenu, 4
Set GetNextMenu = mnuTemp
CopyMemory mnuTemp, 0&, 4
End If
End Function
Private Function GetChildMenu(ByVal mnuItem As Menu) As Menu
Dim mnuType As VB_MENU
Dim mnuTemp As Menu
CopyMemory mnuType, ByVal ObjPtr(mnuItem), Len(mnuType)
If mnuType.pFirstItem <> 0 Then
CopyMemory mnuTemp, mnuType.pFirstItem, 4
Set GetChildMenu = mnuTemp
CopyMemory mnuTemp, 0&, 4
End If
End Function
Private Function GetMenuwID(ByVal mnuItem As Menu) As Long
Dim mnuType As VB_MENU
CopyMemory mnuType, ByVal ObjPtr(mnuItem), Len(mnuType)
GetMenuwID = mnuType.wID
End Function
Private Function GetMenuwShortCut(ByVal mnuItem As Menu) As String
Dim mnuType As VB_MENU
CopyMemory mnuType, ByVal ObjPtr(mnuItem), Len(mnuType)
GetMenuwShortCut = ShortCutwIDtoString(mnuType.wShortCut)
If GetMenuwShortCut <> "" Then
GetMenuwShortCut = vbTab & GetMenuwShortCut
End If
End Function
Private Function GetMenuStyle(ByVal mnuItem As Menu) As Long
Dim mnuType As VB_MENU
CopyMemory mnuType, ByVal ObjPtr(mnuItem), Len(mnuType)
GetMenuStyle = mnuType.dwFlags
End Function
Private Sub Class_Initialize()
SwIDe = swIDeBottom
Enabled = True
End Sub
Private Sub m_cmdButton_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = 0 Then
Select Case KeyCode
Case vbKeySpace, vbKeyReturn
m_cmdButton_MouseDown 0, 0, 0, 0
KeyCode = 0
End Select
End If
End Sub
Private Sub m_cmdButton_MouseDown(Button As Integer, Shift As Integer, x _
As Single, y As Single)
Debug.Assert Not m_mnuItem Is Nothing ' Menu property must be set
Debug.Assert Not m_frmParent Is Nothing ' Parent form must be set
Static bInSub As Boolean
Dim tpm As TPMPARAMS
Dim hMenu As Long
Dim xMenu As Long
Dim yMenu As Long
Dim nAlign As Long
If Not (bInSub) And m_bEnabled Then
bInSub = True
tpm.cbSize = Len(tpm)
GetWindowRect m_cmdButton.hwnd, tpm.rcExclude
hMenu = CopyVBMenu(GetChildMenu(m_mnuItem))
Select Case m_swIDeDropDown
Case swIDeBottom
xMenu = tpm.rcExclude.Left
yMenu = tpm.rcExclude.Bottom
nAlign = TPM_LEFTALIGN Or TPM_TOPALIGN
Case swIDeLeft
xMenu = tpm.rcExclude.Left - 1
yMenu = tpm.rcExclude.Top
nAlign = TPM_RIGHTALIGN Or TPM_TOPALIGN
Case swIDeRight
xMenu = tpm.rcExclude.Right
yMenu = tpm.rcExclude.Top
nAlign = TPM_LEFTALIGN Or TPM_TOPALIGN
Case swIDeTop
xMenu = tpm.rcExclude.Left
yMenu = tpm.rcExclude.Top
nAlign = TPM_LEFTALIGN Or TPM_BOTTOMALIGN
End Select
ReleaseCapture
SendMessage m_cmdButton.hwnd, BM_SETSTATE, True, ByVal 0
TrackPopupMenuEx hMenu, nAlign Or TPM_VERTICAL, xMenu, yMenu, _
m_frmParent.hwnd, tpm
SendMessage m_cmdButton.hwnd, BM_SETSTATE, False, ByVal 0
DestroyMenu hMenu
DoEvents
bInSub = False
End If
End Sub
Private Function CopyVBMenu(mnuType As Menu) As Long
If Not (mnuType Is Nothing) Then
Dim hMenu As Long
Dim hMenuChild As Long
Dim dwStyle As Long
Dim dwAPIStyle As Long
Dim sCaption As String
hMenu = CreatePopupMenu
Do Until mnuType Is Nothing
hMenuChild = CopyVBMenu(GetChildMenu(mnuType))
dwStyle = GetMenuStyle(mnuType)
dwAPIStyle = 0
If dwStyle And flagChecked Then
dwAPIStyle = dwAPIStyle Or MF_CHECKED
End If
If dwStyle And flagDisabled Then
dwAPIStyle = dwAPIStyle Or MF_DISABLED Or MF_GRAYED
End If
If mnuType.Caption = "-" Then
dwAPIStyle = dwAPIStyle Or MF_SEPARATOR
End If
sCaption = mnuType.Caption & GetMenuwShortCut(mnuType)
If Not ((dwStyle And flagHidden) = flagHidden) Then
If hMenuChild = 0 Then
AppendMenu hMenu, MF_STRING Or dwAPIStyle, _
GetMenuwID(mnuType), ByVal sCaption
Else
AppendMenu hMenu, MF_STRING Or MF_POPUP Or _
dwAPIStyle, hMenuChild, ByVal sCaption
End If
End If
Set mnuType = GetNextMenu(mnuType)
Loop
CopyVBMenu = hMenu
End If
End Function
Private Function ShortCutwIDtoString(ByVal nwID As Long) As String
Select Case nwID
Case 1: ShortCutwIDtoString = "Ctrl+A"
Case 2: ShortCutwIDtoString = "Ctrl+B"
Case 3: ShortCutwIDtoString = "Ctrl+C"
Case 4: ShortCutwIDtoString = "Ctrl+D"
Case 5: ShortCutwIDtoString = "Ctrl+E"
Case 6: ShortCutwIDtoString = "Ctrl+F"
Case 7: ShortCutwIDtoString = "Ctrl+G"
Case 8: ShortCutwIDtoString = "Ctrl+H"
Case 9: ShortCutwIDtoString = "Ctrl+I"
Case 10: ShortCutwIDtoString = "Ctrl+J"
Case 11: ShortCutwIDtoString = "Ctrl+K"
Case 12: ShortCutwIDtoString = "Ctrl+L"
Case 13: ShortCutwIDtoString = "Ctrl+M"
Case 14: ShortCutwIDtoString = "Ctrl+N"
Case 15: ShortCutwIDtoString = "Ctrl+O"
Case 16: ShortCutwIDtoString = "Ctrl+P"
Case 17: ShortCutwIDtoString = "Ctrl+Q"
Case 18: ShortCutwIDtoString = "Ctrl+R"
Case 19: ShortCutwIDtoString = "Ctrl+S"
Case 20: ShortCutwIDtoString = "Ctrl+T"
Case 21: ShortCutwIDtoString = "Ctrl+U"
Case 22: ShortCutwIDtoString = "Ctrl+V"
Case 23: ShortCutwIDtoString = "Ctrl+W"
Case 24: ShortCutwIDtoString = "Ctrl+X"
Case 25: ShortCutwIDtoString = "Ctrl+Y"
Case 26: ShortCutwIDtoString = "Ctrl+Z"
Case 27: ShortCutwIDtoString = "F1"
Case 28: ShortCutwIDtoString = "F2"
Case 29: ShortCutwIDtoString = "F3"
Case 30: ShortCutwIDtoString = "F4"
Case 31: ShortCutwIDtoString = "F5"
Case 32: ShortCutwIDtoString = "F6"
Case 33: ShortCutwIDtoString = "F7"
Case 34: ShortCutwIDtoString = "F8"
Case 35: ShortCutwIDtoString = "F9"
Case 37: ShortCutwIDtoString = "F11"
Case 38: ShortCutwIDtoString = "F12"
Case 39: ShortCutwIDtoString = "Ctrl+F1"
Case 40: ShortCutwIDtoString = "Ctrl+F2"
Case 41: ShortCutwIDtoString = "Ctrl+F3"
Case 42: ShortCutwIDtoString = "Ctrl+F4"
Case 43: ShortCutwIDtoString = "Ctrl+F5"
Case 44: ShortCutwIDtoString = "Ctrl+F6"
Case 45: ShortCutwIDtoString = "Ctrl+F7"
Case 46: ShortCutwIDtoString = "Ctrl+F8"
Case 47: ShortCutwIDtoString = "Ctrl+F9"
Case 49: ShortCutwIDtoString = "Ctrl+F11"
Case 50: ShortCutwIDtoString = "Ctrl+F12"
Case 51: ShortCutwIDtoString = "Shift+F1"
Case 52: ShortCutwIDtoString = "Shift+F2"
Case 53: ShortCutwIDtoString = "Shift+F3"
Case 54: ShortCutwIDtoString = "Shift+F4"
Case 55: ShortCutwIDtoString = "Shift+F5"
Case 56: ShortCutwIDtoString = "Shift+F6"
Case 57: ShortCutwIDtoString = "Shift+F7"
Case 58: ShortCutwIDtoString = "Shift+F8"
Case 59: ShortCutwIDtoString = "Shift+F9"
Case 61: ShortCutwIDtoString = "Shift+F11"
Case 62: ShortCutwIDtoString = "Shift+F12"
Case 63: ShortCutwIDtoString = "Shift+Ctrl+F1"
Case 64: ShortCutwIDtoString = "Shift+Ctrl+F2"
Case 65: ShortCutwIDtoString = "Shift+Ctrl+F3"
Case 66: ShortCutwIDtoString = "Shift+Ctrl+F4"
Case 67: ShortCutwIDtoString = "Shift+Ctrl+F5"
Case 68: ShortCutwIDtoString = "Shift+Ctrl+F6"
Case 69: ShortCutwIDtoString = "Shift+Ctrl+F7"
Case 70: ShortCutwIDtoString = "Shift+Ctrl+F8"
Case 71: ShortCutwIDtoString = "Shift+Ctrl+F9"
Case 73: ShortCutwIDtoString = "Shift+Ctrl+F11"
Case 74: ShortCutwIDtoString = "Shift+Ctrl+F12"
Case 75: ShortCutwIDtoString = "Ctrl+Ins"
Case 76: ShortCutwIDtoString = "Shift+Ins"
Case 77: ShortCutwIDtoString = "Del"
Case 78: ShortCutwIDtoString = "Shift+Del"
Case 79: ShortCutwIDtoString = "Alt+Bksp"
End Select
End Function
'-------- End of class: clsButtonMenu
|