use "slPopUp"
Sub Click(Source As Button)
Dim objPopUp As New PopUp
With objPopUp
.AddEntry "Main/aaa","aaa"
.AddEntry "Main/-","aaa"
.AddEntry "Main/Sub1/bbb","bbb"
.AddEntry "Main/Sub1/-",""
.AddEntry "Main/Sub1/Sub2/ccc","ccc"
.AddEntry "Main/Sub1/Sub2/-",""
.AddEntry "Main/Sub2/bbb","bbb"
.AddEntry "Main/Sub2/-",""
.AddEntry "Main/Sub2/Sub2/ccc","ccc"
.AddEntry "Main/Sub2/Sub2/-",""
.AddEntry "Main/ddd","ddd"
.AddEntry "Test2","ddd"
.Display
If Not .Label="" Then
Msgbox "Label: " & .Label & Chr(13) & "ID: " & .ID,,"Label"
End If
End With
End Sub
Option Public
Option Declare
Const cLibName="slPopup"
' # #########################################
' # Win-API 32 Strukturen:
' # Struktur für Fensterverwaltung
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' # Struktur für Positionsbestimmung der Maus
Type POINTAPI
x As Long
y As Long
End Type
' # Struktur für Win-API-Popup-Menü-Struktur
Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
Alias As String ' # zusätzlich deklariert
End Type
' # Win-API-Konstanten:
' # ... MENUITEMINFO fMask-Konstanten
Const MIIM_STATE = &H1 ' benutzt die fState-Optionen
Const MIIM_ID = &H2 ' benutzt die wID-Option
Const MIIM_SUBMENU = &H4 ' benutzt die hSubMenu-Option
Const MIIM_CHECKMARKS = &H8 ' benutzt die hbmpChecked- und hb,pUnchecked-Optionen
Const MIIM_DATA = &H20 ' benutzt die dwItemDate-Option
Const MIIM_TYPE = &H10 ' benutzt die dwTypeData-Option
' MENUITEMINFO fType-Konstanten
Const MFT_BITMAP = &H4 ' Das Handle des Bitmaps muss in dwTypeData übergeben werden. Kann nicht mit MFT_SEPARATOR oder MFT_STRING kombiniert werden
Const MFT_MENUBARBREAK = &H20 ' platziert das Menü ein einer neuen Zeile oder Spalte und zeichnet über und unter dem Eintrag einen Separator
Const MFT_MENUBREAK = &H40 ' das Gleiche wie MFT_MENUBARBREAK, nur ohne Separator
Const MFT_OWNERDRAW = &H100 ' überlässt das Neuzeichnen des Menüs dem Fenster
Const MFT_RADIOCHECK = &H200 ' zeigt einen Radiobutton als Checked/Unchecked an
Const MFT_RIGHTJUSTIFY = &H4000 ' richtet ein Menü rechtsbündig aus
Const MFT_RIGHTORDER = &H2000 ' (Win 9x, 2000) die Menüs platzieren sich rechts voneinander und es wird Text von rechts nach links unterstützt
Const MFT_SEPARATOR = &H800 ' zeichnet eine horizontale Linie in den MenueEintrag. Kann nicht mit MFT_BITMAP oder MFT_STRING kombiniert werden
Const MFT_STRING = &H0 ' der MenueEintrag wird mit einem String gefüllt, deTypeData ist der String, der angezeigt werden soll und cch die Länge des Strings.
' MENUITEMINFO fState-Konstanten
Const MFS_CHECKED = &H8 ' MenueEintrag ist markiert
Const MFS_DEFAULT = &H1000 ' MenueEintrag ist die Standard-Auswahl
Const MFS_DISABLED = &H2 ' MenueEintrag ist deaktiviert
Const MFS_ENABLED = &H0 ' MenueEintrag ist aktiviert
Const MFS_GRAYED = &H1 ' MenueEintrag ist grau und deaktiviert
Const MFS_HILITE = &H80 ' MenueEintrag hat die Selektierung
Const MFS_UNCHECKED = &H0 ' MenueEintrag ist nicht markiert
Const MFS_UNHILITE = &H0 ' MenueEintrag hat nicht die Selektierung
' Konstanten für Win-API-TrackPopupmenu und Flags-Konstanten
Const TPM_CENTERALIGN = &H4 ' positioniert das Menü horizontal in der Mitte von x
Const TPM_LEFTALIGN = &H0 ' positioniert das Menü horizontal mit dem linken Rand auf x
Const TPM_RIGHTALIGN = &H8 ' positioniert das Menü horizontal mit dem rechten Rand auf x
Const TPM_BOTTOMALIGN = &H20 ' positioniert das Menü mit dem unteren Rand auf y
Const TPM_TOPALIGN = &H0 ' positioniert das Menü mit dem oberen Rand auf y
Const TPM_VCENTERALIGN = &H10 ' positioniert das Menü vertikal in der Mitte von y
Const TPM_NONOTIFY = &H80 ' sendet kein WM_COMMAND an das Elternfenster des Menüs bei Ereignissen
Const TPM_RETURNCMD = &H100 ' die Funktion gibt den ID des Menüs zurück, das gewählt wurde
Const TPM_LEFTBUTTON = &H0 ' erlaubt dem Benutzer nur das Markieren der Einträge über die linke Maustaste und die Tastatur
Const TPM_RIGHTBUTTON = &H2 ' erlaubt den Benutzer, die Einträge mit jedem Mausbutton und der Tastatur zu wählen
' # WinAPI.Popup-Selection-Funktionen
Declare Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI) As Long
Declare Function CreatePopupMenu Lib "user32" Alias "CreatePopupMenu" ( ) As Long
Declare Function InsertMenuItem Lib "user32.dll" Alias "InsertMenuItemA" ( ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As MENUITEMINFO ) 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 RECT) As Long
Declare Function DestroyMenu Lib "user32" Alias "DestroyMenu" (ByVal hMenu As Long) As Long
'Declare Function GetActiveWindow Lib "user32" Alias "GetActiveWindow" () As Long
Declare Function GetFocus Lib "user32" Alias "GetFocus" () As Long
Class PopUp
Private aryEntries() As String
Private mstrLabel As String
Private mstrID As String
Private mlngEntriesCount As Long
Sub AddEntry(Label As String, ID As String)
ReDim Preserve aryEntries(mlngEntriesCount)
mlngEntriesCount=mlngEntriesCount+1
aryEntries(UBound(aryEntries))=Label & "|" & ID
End Sub
Sub Display
popupSelect
End Sub
Property Get Label As String
Label=mstrLabel
End Property
Property Get ID As String
ID=mstrID
End Property
Private Sub popupSelect()
' # Einen Wert über ein Popup-Menü ermitteln.
' # sMenu => Variant-Textliste
' # ... ein Element hat die Syntax "<Hauptmenü-Label> / <Submenu-Label> | <Alias>"
' # ... enthält der String einen Slash, so wird ein Untermenü erzeugt
' # ... enthält der String eine Pipe, so wird der Teil danach als Alias verwendet
' # ... es kann pro String nur einen Slash und eine Pipe geben. weitere Kaskadierungen sind nicht vorgesehen.
' # Rückgabe ist ein Array mit 2 Elementen => PopuSelect(0) = ausgewähltes Label, PopupSelect(1) = Alias des ausgewählten Labels
Const cLSName = "PopupSelect"
On Error GoTo ErrorHandle
Dim MenueEintrag() As MENUITEMINFO
Dim Flags As Long
Dim hWnd As Long
Dim pos As POINTAPI
Dim hReturn As Long
Dim hPopupMenu As Long
Dim rectdata As RECT
'
Dim hSubs List As Long
Dim vParam As Variant
Dim sLabel As String
Dim sLabels() As String
Dim sAlias As String
Dim countMenu As Integer
Dim vMenuEntries As Variant
Dim vLabels As Variant
Dim hParent As long
Dim i As long
'
' # Handle des aktuellen Fensters
hWnd = GetFocus( )
'
' Position des Fensters ermitteln
GetCursorPos pos
'
' Popupmenü erstellen
hPopupMenu = CreatePopupMenu()
'
' # Bilden des Menübaumes
ForAll sEntry In aryEntries
countMenu = countMenu + 1
ReDim Preserve MenueEintrag(1 To countMenu)
If InStr(sEntry, "|") > 0 Then
vParam = Split(sEntry,"|")
sLabel = Trim(vParam(0))
sAlias = Trim(vParam(1))
Else
sLabel = Trim(sEntry)
sAlias = sLabel
End If
'
vLabels=Split(sLabel,"/")
ReDim sLabels(UBound(vLabels))
For i=LBound(vLabels) To UBound(vLabels)
sLabels(i)=Trim(vLabels(i))
Next
hParent=hPopupMenu
sLabel=""
For i=0 To UBound(sLabels)-1
If sLabel="" then
sLabel=sLabels(i)
Else
sLabel=sLabel & "/" & sLabels(i)
End if
If Not IsElement(hSubs(sLabel)) Then
hSubs(sLabel) = CreatePopupMenu()
CreateMenueEntry hParent, hSubs(sLabel), sLabels(i) & "/", "", MenueEintrag(countMenu), countMenu
countMenu = countMenu + 1
ReDim Preserve MenueEintrag(1 To countMenu)
End If
hParent=hSubs(sLabel)
Next i
CreateMenueEntry hParent, 0, sLabels(UBound(sLabels)), sAlias, MenueEintrag(countMenu), countMenu
End ForAll
'
' Menü anzeigen
'Print "Position x = " & pos.x & " / y = " & pos.y
'
Flags = TPM_TOPALIGN Or TPM_LEFTALIGN Or TPM_NONOTIFY Or TPM_RETURNCMD
'
hReturn = TrackPopupMenu(hPopupMenu , Flags, pos.x , pos.y , 0&, hwnd , rectdata)
'
' gewähltes Menü ausgeben, wenn eines gewählt wurde
If hReturn <> 0 Then
'MsgBox "Sie haben auf """ & Replace(MenueEintrag(Retval).Alias, "&", "", 1, 1) & """ gedrückt"
End If
'
' # Speicherplatz wieder freigeben...
DestroyMenu hPopupMenu
ForAll handles In hSubs
DestroyMenu handles
End ForAll
'
If hReturn > 0 Then
mstrLabel=Replace(MenueEintrag( hReturn ).dwTypeData, "&", "", 1, 1)
mstrID=Replace(MenueEintrag( hReturn ).Alias , "&", "", 1, 1)
Else
' # skip - OK - leeres Array
mstrLabel=""
mstrID=""
End If
Exit Sub
ErrorHandle:
MsgBox cLibName & "." & cLSName & ": " & Error , 16 , "Fehler " & Err & " in Zeile " & Erl
End Erl()
End Sub
Private sub createMenueEntry(hPopupMenu As Long, hSub1 As Long, sEntry As String, sAlias As String, MEintrag As MenuItemInfo, Index As Integer)
' # Erstellt einen Menüeintrag
Const cLSName = "CreateMenueEntry"
On Error GoTo ErrorHandle
Dim vReturn As Variant
' MenueEintrag hinzufügen (sEntry)
MEintrag.cbSize = Len(MEintrag)
MEintrag.dwTypeData = sEntry
MEintrag.Alias = sAlias
MEintrag.cch = Len(Trim$(MEintrag.dwTypeData))
'
If Right(sEntry, 1) = "/" Then
MEintrag.dwTypeData = Replace(sEntry, "/", "")
MEintrag.fMask = MIIM_TYPE Or MIIM_ID Or MIIM_SUBMENU
MEintrag.hSubMenu = hSub1
MEintrag.fState = 0 ' # MFS_CHECKED
Else
MEintrag.fMask = MIIM_TYPE Or MIIM_ID
MEintrag.fState = MFS_DEFAULT Or MFS_HILITE
End If
'
If sEntry = "-" Then
MEintrag.fType = MFT_SEPARATOR
Else
MEintrag.fType = MFT_STRING
End If
'
MEintrag.wID = Index
'
vReturn = InsertMenuItem(hPopupMenu, 0&, 0&, MEintrag)
'
If vReturn = 0 Then
Print "... MenueEintrag konnte nicht hinzugefügt werden: " & sEntry & "."
End If
Exit Sub
ErrorHandle:
MsgBox cLibName & "." & cLSName & ": " & Error, 16, "Fehler " & Err & " in Zeile " & Erl
End Erl()
End Sub
End Class