UTF-8 Datei nach Char

Userform mit Menü

Userformen bieten standardmäßig keine Menüs. Mit ein paar API-Funktionen kann man sich aber ein Menü selber basteln.

Leider gibt es auch keine Ereignisprozeduren, die beim Anklicken oder Auswählen eines Punktes ausgeführt werden. Man muss dazu die Fensternachrichten abhören und bei der richtigen Nachricht reagieren. Excel ist zwar nicht gerade die erste Wahl für solch ein Subclassing, aber bei einem flotten Rechner sollte das ohne Probleme funktionieren.

Die Funktion, auf die die Fensternachrichten umgeleitet wird, muss sich in einem Standardmodul befinden. Jede Unterbrechung dort, oder jeder unbehandelte Fehler können fatale Folgen haben.

Prinzipielle Vorgehensweise:

Mainmenü erzeugen mit CreateMenu, Handle merken
1. Hauptmenü erzeugen mit CreatePopupMenu, Handle merken
2. Hauptmenü erzeugen mit CreatePopupMenu, Handle merken
Ein Untermenü erzeugen mit CreatePopupMenu, Handle merken

Die Struktur MENUITEMINFO ausfüllen, die Angaben zu einem
Menüpunkt (nicht verwechseln mit einem Menü oder Popupmenü)

cbSize enthält die Länge der Struktur

fMask enthält die Infos, ob ein Untermenü zu diesem Punkt
existieren soll. Weiterhin Angaben, ob eine ID oder der Typ
angegeben wirden, oder Checkboxen angezeigt werden sollen.

fType gibt den Datentyp an (String)

wID muss eine eindeutige ID sein, damit beim Subclassing
der Punkt identifiziert werden kann.

hSubMenu das Handle eines erzeugten Popupmenus, bei fMask
muss dann aber MIIM_SUBMENU gesetzt sein.

dwTypeData in den meisten Fällen der String, der angezeigt
werden soll. Das Kaufmännische Und (&) unterstreicht den
folgenden Buchstaben.

Anschließend mit InsertMenuItem den Menüpunkt hinzufügen:

InsertMenuItem ÜbergeordnetesMenü, 0&, True, MnuItem

Der zweite Parameter gibt die Position an,
der dritte, ob die Position ausgewertet werden soll,
der vierte ist die vorher ausgefüllte Struktur mit den Infos.

Bei einem weiteren Untermenü muss bei dem übergeordneten Menüpunkt das Flag MIIM_SUBMENU gesetzt sein.

Beispieldatei (MenuUf.zip 24 kB)

In ein allgemeines Modul:

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 = 225
                 MsgBox "'Untermenüpunkt Ü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
Dim lngUntermenü     As Long
Dim lngHauptmenü1    As Long
Dim lngHauptmenü2    As Long
Dim lngHauptmenü3    As Long

   ' Mainmenü anlegen
   mlngMenuParent = CreateMenu()
   lngHauptmenü1 = CreatePopupMenu()
   lngHauptmenü2 = CreatePopupMenu()
   lngUntermenü = CreatePopupMenu()



   With MnuItem
       ' Länge der Struktur
       .cbSize = Len(MnuItem)

       ' 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 = lngHauptmenü1 ' Angabe des verbundenen Submenüs
       .dwTypeData = "&Datei" ' Menütext
       ' 1. Hauptmenü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 lngHauptmenü1, 0&, True, MnuItem



       ' 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 = lngHauptmenü2 ' 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 lngHauptmenü2, 0&, True, MnuItem



       ' 2. Submenüpunkt, 2. Hauptmenü
       .fMask = MIIM_TYPE Or MIIM_ID Or MIIM_SUBMENU
       .fType = MF_STRING ' Text als Menüpunkt ( ev. Bitmap)
       .wID = 220& ' Eindeutige ID
       .hSubMenu = lngUntermenü ' enthält ein Submenü
       .dwTypeData = "&Über" ' Menütext
       ' Menüpunkt ins 2. Submenü einfügen
       InsertMenuItem lngHauptmenü2, 2&, True, MnuItem


       .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 = 225& ' Eindeutige ID
       .hSubMenu = 0 ' enthält kein Submenü
       .dwTypeData = "&Untermenü Über" ' Menütext
       ' Untermenüpunkt einfügen
       InsertMenuItem lngUntermenü, 0&, 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