AW: Menü in Userform 3-Stufig
05.01.2006 12:08:24
Holger
Das mit der 0 bezieht sich immer auf das Menü danach. Da wo die Null ist, sind die Submenüs in einem Submenü. Danach kommt keins mehr. Die werden aber nicht angezeigt. Das ist mein Problem.
Hier mal der komplette Originalcode. Mit nur einem Submenü. Die Submenüs da drin möchte ich nochmal verschachteln.
Der Code der bei
Private Sub MakeMenu() steht muss abgeändert werden. Das andere sind die API´s:
Option Explicit
Private Declare Function CallWindowProc _
Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Private Const WM_COMMAND As Long = &H111
Public glngOldProc As Long
Public Function NewProc(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long _
) As Long
If Msg = WM_COMMAND Then
If lParam = 0 Then
Select Case wParam
Case Is = 120
MsgBox "'Beenden' gewählt"
Case Is = 210
MsgBox "'Hilfe' gewählt"
Case Is = 220
MsgBox "'Über' gewählt"
End Select
End If
End If
NewProc = CallWindowProc(glngOldProc, hWnd, Msg, wParam, lParam)
End Function
In eine Userform mit dem Namen ufMenu:
Option Explicit
Private Declare Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long _
) As Long
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As Long
Private Declare Function CreatePopupMenu _
Lib "user32" () As Long
Private Declare Function CreateMenu _
Lib "user32" () As Long
Private Declare Function DestroyMenu _
Lib "user32" ( _
ByVal glngMenu As Long _
) As Long
Private Declare Function DrawMenuBar _
Lib "user32" ( _
ByVal hWnd As Long _
) As Long
Private Declare Function SetMenu _
Lib "user32" ( _
ByVal hWnd As Long, _
ByVal glngMenu As Long _
) As Long
Private Declare Function InsertMenuItem _
Lib "user32" Alias "InsertMenuItemA" ( _
ByVal hMenu As Long, _
ByVal un As Long, _
ByVal bool As Long, _
lpcMenuItemInfo As MENUITEMINFO _
) As Long
Private 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
End Type
Private Const MF_CHECKED = &H8&
Private Const MF_APPEND = &H100&
Private Const MF_DISABLED = &H2&
Private Const MF_GRAYED = &H1&
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const MIIM_STATE As Long = &H1&
Private Const MIIM_ID As Long = &H2&
Private Const MIIM_TYPE = &H10
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_CHECKMARKS = &H8
Private Const GWL_WNDPROC = (-4)
Private mlngUserform As Long
Private mlngMenuParent As Long
Private Sub MakeMenu()
Dim MnuItem As MENUITEMINFO
Dim lngSub As Long
' Mainmenü anlegen
mlngMenuParent = CreateMenu()
With MnuItem
' Länge der Struktur
.cbSize = Len(MnuItem)
' 1. Submenü anlegen
lngSub = CreatePopupMenu()
' 1. Hauptmenü
.fMask = MIIM_TYPE Or MIIM_ID Or MIIM_SUBMENU
.fType = MF_STRING ' Text als Menüpunkt ( ev. Bitmap)
.wID = 100& ' Eindeutige ID
.hSubMenu = lngSub ' Angabe des verbundenen Submenüs
.dwTypeData = "&Datei" ' Menütext
' Menüpunkt ins Mainmenü einfügen
InsertMenuItem mlngMenuParent, 0&, True, MnuItem
' 1. Submenüpunkt, 1. Hauptmenü
.fMask = MIIM_TYPE Or MIIM_ID Or MIIM_STATE
.fType = MF_STRING ' Text als Menüpunkt ( ev. Bitmap)
'.fState = MF_GRAYED ' Ausgegraut
.wID = 120& ' Eindeutige ID
.hSubMenu = 0 ' enthält kein Submenü
.dwTypeData = "&Beenden" ' Menütext
' Menüpunkt ins 1. Submenü einfügen
InsertMenuItem lngSub, 0&, True, MnuItem
' 2. Submenü anlegen
lngSub = CreatePopupMenu()
' 2. Hauptmenü
.fMask = MIIM_TYPE Or MIIM_ID Or MIIM_SUBMENU
.fType = MF_STRING ' Text als Menüpunkt ( ev. Bitmap)
.wID = 200& ' Eindeutige ID
.hSubMenu = lngSub ' Angabe des verbundenen Submenüs
.dwTypeData = "&?" ' Menütext
' Menüpunkt ins Mainmenü einfügen
InsertMenuItem mlngMenuParent, 1&, True, MnuItem
' 1. Submenüpunkt, 2. Hauptmenü
.fMask = MIIM_TYPE Or MIIM_ID
.fType = MF_STRING ' Text als Menüpunkt ( ev. Bitmap)
.wID = 210& ' Eindeutige ID
.hSubMenu = 0 ' enthält kein Submenü
.dwTypeData = "&Hilfe" ' Menütext
' Menüpunkt ins 2. Submenü einfügen
InsertMenuItem lngSub, 0&, True, MnuItem
' 2. Submenüpunkt, 2. Hauptmenü
.fMask = MIIM_TYPE Or MIIM_ID Or MIIM_CHECKMARKS Or MIIM_STATE
.fType = MF_STRING ' Text als Menüpunkt ( ev. Bitmap)
.fState = MF_CHECKED ' Haken gesetzt
.wID = 220& ' Eindeutige ID
.hSubMenu = 0 ' enthält kein Submenü
.dwTypeData = "&Über" ' Menütext
' Menüpunkt ins 2. Submenü einfügen
InsertMenuItem lngSub, 2&, True, MnuItem
End With
' Menü mit Userform verbinden
SetMenu mlngUserform, mlngMenuParent
DrawMenuBar mlngUserform
' WindowProc umleiten
glngOldProc = SetWindowLong(mlngUserform, _
GWL_WNDPROC, AddressOf NewProc)
End Sub
Private Function GetMyHandle() As Long
Dim strMe As String
Dim strFind As String
strFind = "asdfghjk"
strMe = Me.Caption
Me.Caption = strFind
GetMyHandle = FindWindow(vbNullString, Me.Caption)
Me.Caption = strMe
End Function
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
Unload Me
End Sub
Private Sub UserForm_Terminate()
DestroyMenu mlngMenuParent
SetWindowLong mlngUserform, GWL_WNDPROC, glngOldProc
End Sub
Private Sub UserForm_Initialize()
mlngUserform = GetMyHandle
MakeMenu
End Sub