Option Compare Database
Option Explicit
‚— API-Konstanten
Private Const WM_COMMAND = &H111
Private Const WM_LBUTTONUP = &H202
Private Const MF_INSERT = &H0&
Private Const MF_CHANGE = &H80&
Private Const MF_APPEND = &H100&
Private Const MF_DELETE = &H200&
Private Const MF_REMOVE = &H1000&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_SEPARATOR = &H800&
Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const MF_UNCHECKED = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_USECHECKBITMAPS = &H200&
Private Const MF_STRING = &H0&
Private Const MF_BITMAP = &H4&
Private Const MF_OWNERDRAW = &H100&
Private Const MF_POPUP = &H10&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_UNHILITE = &H0&
Private Const MF_HILITE = &H80&
Private Const MF_SYSMENU = &H2000&
Private Const MF_HELP = &H4000&
Private Const MF_MOUSESELECT = &H8000&
Private Const TPM_LEFTBUTTON = &H0&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_CENTERALIGN = &H4&
Private Const TPM_RIGHTALIGN = &H8&
‚—API-Strukturen
Type tPoint
X As Long
Y As Long
End Type
Type tRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type tMsg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
Time As Long
P As tPoint
End Type
‚—API-Deklarationen
Declare Function CreatePopupMenu Lib „user32“ () As Long
Declare Function AppendMenu Lib „user32“ Alias „AppendMenuA“ (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Declare Function DestroyMenu Lib „user32“ (ByVal hMenu As Long) As Long
Declare Function TrackPopUpMenu Lib „user32“ Alias „TrackPopupMenu“ (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lprc As tRect) As Long
Declare Function GetMessage Lib „user32“ Alias „GetMessageA“ (lpMsg As tMsg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare Function GetCursorPos Lib „user32“ (lpPoint As tPoint) As Long
Function DoPopup(strEntries As String) As Integer
Dim hMenu As Long, hWnd As Long, strX As String
Dim intCnt As Integer
Dim CurrPos As tPoint, aRect As tRect, aMsg As tMsg
Dim Result As Variant
intCnt = 1
hMenu = CreatePopupMenu()
If Right$(strEntries, 1) <> „|“ Then strEntries = strEntries + „|“
While strEntries <> „“
strX = Left$(strEntries, InStr(strEntries, „|“) – 1)
strEntries = Mid$(strEntries, InStr(strEntries, „|“) + 1)
If strX = „=“ Then ‚Separator…
Result = AppendMenu(hMenu, MF_SEPARATOR, 0, „“)
ElseIf Left$(strX, 1) = „>“ Then ‚Neue Spalte…
strX = Mid$(strX, 2)
Result = AppendMenu(hMenu, MF_MENUBARBREAK, intCnt, strX)
intCnt = intCnt + 1
ElseIf Left$(strX, 1) = „~“ Then ‚Deaktiviert…
strX = Mid$(strX, 2)
Result = AppendMenu(hMenu, MF_GRAYED, intCnt, strX)
intCnt = intCnt + 1
ElseIf Left$(strX, 1) = „+“ Then ‚Mit Häkchen…
strX = Mid$(strX, 2)
Result = AppendMenu(hMenu, MF_ENABLED + MF_CHECKED, intCnt, strX)
intCnt = intCnt + 1
Else ‚Normaler Eintrag…
Result = AppendMenu(hMenu, MF_ENABLED, intCnt, strX)
intCnt = intCnt + 1
End If
Wend
GetCursorPos CurrPos ‚Aktuelle Cursorposition?
hWnd = Screen.ActiveForm.hWnd ‚Handle auf das Formular
Result = TrackPopUpMenu(hMenu, TPM_LEFTALIGN, CurrPos.X, CurrPos.Y, 0, hWnd, aRect)
Result = GetMessage(aMsg, hWnd, WM_COMMAND, WM_LBUTTONUP)
If aMsg.Message = WM_COMMAND Then
DoPopup = aMsg.wParam
Else
DoPopup = 0
End If
Result = DestroyMenu(hMenu)
End Function