Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0770: Ausgewählten Menüpunkt im Kontextmenü einer TextBox ermitteln

VB 5/6-Tipp 0770: Ausgewählten Menüpunkt im Kontextmenü einer TextBox ermitteln

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), FindWindowExA (FindWindowEx), GetMenuItemInfoA (GetMenuItemInfo), GetMenuStringA (GetMenuString), SetWindowLongA (SetWindowLong)

Download: Download des Beispielprojektes [5.67 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'----------- Anfang Projektdatei ContextMenu.vbp  -----------
'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Textfeld "Text1"
Option Explicit

Private Declare Function FindWindowEx Lib "user32" _
                         Alias "FindWindowExA" ( _
                         ByVal hWnd1 As Long, _
                         ByVal hWnd2 As Long, _
                         ByVal lpsz1 As String, _
                         ByVal lpsz2 As String) As Long
                         
Private WithEvents clsCM As clsContextMenu

Private Sub clsCM_MouseUp(ByVal MenuHandle As Long, ByVal MenuItemID As _
    Long, ByVal MenuString As String, ByVal ScreenX As Long, ByVal _
    ScreenY As Long)
    
    Dim strMenu As String
    
    strMenu = Replace$(MenuString, "&", vbNullString)
    
    MsgBox "Sie haben im Kontextmenü den Menüpunkt '" & strMenu & "' " & _
        "ausgewählt.", vbOKOnly Or vbInformation, "Kontextmenü"
        
End Sub

Private Sub Form_Load()
    
    Dim lngTbWnd As Long

    Set clsCM = New clsContextMenu
    
    clsCM.Hook Text1.hwnd
    ' clsCM.Hook RichTextBox1.hwnd
    ' clsCM.Hook MaskEdBox1.hwnd
    
    ' TextBox in der ComboBox
    ' lngTbWnd = FindWindowEx(Combo1.hwnd, 0&, "Edit", vbNullString)
    ' If lngTbWnd <> 0 Then
    '     clsCM.Hook lngTbWnd
    ' End If
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    Set clsCM = Nothing
    
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'--- Anfang Modul "modContextMenu" alias modContextMenu.bas ---
Option Explicit

Public colMenu As New Collection
Public colObject As New Collection

Public Function MenuProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal _
    wParam As Long, ByVal lParam As Long) As Long
    
    Dim clsCMM As New clsContextMenu
    
    Set clsCMM = colMenu.Item("Menu" & CStr(hwnd))
    
    If Not clsCMM Is Nothing Then
    
        MenuProc = clsCMM.MenuMsgRec(uMsg, wParam, lParam)
        
    End If
    
End Function

Public Function ObjectProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal _
    wParam As Long, ByVal lParam As Long) As Long
    
    Dim clsCMO As New clsContextMenu
    
    Set clsCMO = colObject.Item("Object" & CStr(hwnd))
    
    If Not clsCMO Is Nothing Then
    
        ObjectProc = clsCMO.ObjectMsgRec(uMsg, wParam, lParam)
        
    End If
    
End Function
'--- Ende Modul "modContextMenu" alias modContextMenu.bas ---
'--- Anfang Klasse "clsContextMenu" alias clsContextMenu.cls  ---
Option Explicit
' Klasse zum ermitteln des ausgewählten Menüpunktes in einem
' Kontextmenü. Diese Klasse funktioniert zur Zeit mit einer
' TextBox, RichTextBox, MaskEdBox und der TextBox in der ComboBox.
' Durchaus Möglich das die Klasse auch mit anderen Controls
' funktioniert die ein Kontextmenü haben.

' ---=== Const ===---
Private Const GWL_WNDPROC As Long = (-4)
Private Const MIIM_STATE As Long = &H1
Private Const MFS_DISABLED As Long = &H3&
Private Const MSGF_MENU As Long = 2
Private Const WM_CHAR As Long = &H102
Private Const WM_CONTEXTMENU As Long = &H7B
Private Const WM_DESTROY As Long = &H2
Private Const WM_ENTERIDLE As Long = &H121
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_MENUSELECT As Long = &H11F
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_WINDOWPOSCHANGING As Long = &H46
Private Const WM_WINDOWPOSCHANGED As Long = &H47

' ---=== Type ===---
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

' ---=== USER32 ===---
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 Declare Function GetMenuItemInfo Lib "user32.dll" _
                         Alias "GetMenuItemInfoA" ( _
                         ByVal hMenu As Long, _
                         ByVal uItem As Long, _
                         ByVal fByPosition As Boolean, _
                         ByRef lpMenuItemInfo As MENUITEMINFO) As Long

Private Declare Function GetMenuString Lib "user32" _
                         Alias "GetMenuStringA" ( _
                         ByVal hMenu As Long, _
                         ByVal ItemId As Long, _
                         ByVal Buffer As String, _
                         ByVal BufferMax As Long, _
                         ByVal Flag As Long) As Long
                         
Private Declare Function SetWindowLong Lib "user32" _
                         Alias "SetWindowLongA" ( _
                         ByVal hwnd As Long, _
                         ByVal nIndex As Long, _
                         ByVal dwNewLong As Long) As Long
                         
' ---=== Variablen ===---
Private m_hMenu As Long
Private m_HookWnd As Long
Private m_MenuWnd As Long
Private m_WndProc As Long
Private m_MenuProc As Long
Private m_MenuItemID As Long
Private m_MenuTracking As Boolean

' ---=== Event ===---
Public Event MouseUp(ByVal MenuHandle As Long, ByVal MenuItemID As Long, _
    ByVal MenuString As String, ByVal ScreenX As Long, ByVal ScreenY As Long)
    
Private Function GetMenuStringFromItemID(ByVal MenuItemID As Long) As _
    String
    
    Dim lngRet As Long
    Dim strMenuString As String
    
    strMenuString = Space$(256)
    
    lngRet = GetMenuString(m_hMenu, MenuItemID, strMenuString, Len( _
        strMenuString), 0&)
        
    GetMenuStringFromItemID = Left$(strMenuString, lngRet)
    
End Function

Private Sub GetSelectedMenuItem(ByVal MenuItemID As Long, Optional ByVal _
    ScreenPos As Long = 0)
    
    Dim Lo As Long
    Dim Hi As Long
    Dim lngMenuItemID As Long
    Dim tMII As MENUITEMINFO
    
    tMII.cbSize = Len(tMII)
    tMII.fMask = MIIM_STATE ' Status des MenüItems
    
    ' MenüItemInfo auslesen
    If GetMenuItemInfo(m_hMenu, MenuItemID, False, tMII) <> 0 Then
    
        ' Wenn der Menüeintrag nicht deaktiv ist
        If (tMII.fState And MFS_DISABLED) <> MFS_DISABLED Then
        
            ' lParam in Lo und Hi aufsplitten
            Call GetShort(ScreenPos, Lo, Hi)
            
            ' Event auslösen
            RaiseEvent MouseUp(m_hMenu, MenuItemID, _
                GetMenuStringFromItemID(MenuItemID), Lo, Hi)
                
        End If
    End If
    
End Sub

Private Sub GetShort(ByVal Value As Long, ByRef Lo As Long, ByRef Hi As _
    Long)
    
    Lo = Value And &H7FFF
    Hi = Value \ &H10000
    
End Sub

Public Sub Hook(ByVal hwnd As Long)

    If m_HookWnd <> 0 Then
    
        Call UnHook
        
    End If
    
    m_HookWnd = hwnd
    colObject.Add Me, "Object" & CStr(m_HookWnd)
        
    m_WndProc = SetWindowLong(m_HookWnd, GWL_WNDPROC, AddressOf _
        ObjectProc)
            
End Sub

Private Sub HookMenu(ByVal hwnd As Long)

    If m_MenuWnd <> 0 Then
    
        Call UnHookMenu
        
    End If
    
    m_MenuWnd = hwnd
    colMenu.Add Me, "Menu" & CStr(m_MenuWnd)
        
    m_MenuProc = SetWindowLong(m_MenuWnd, GWL_WNDPROC, AddressOf _
        MenuProc)
            
End Sub

Friend Function MenuMsgRec(ByVal uMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
    Dim lngMenuItemPos As Long
    
    MenuMsgRec = CallWindowProc(m_MenuProc, m_MenuWnd, uMsg, wParam, _
        lParam)
    
    Select Case uMsg
    
    Case &H1E5 'MN_SELECTITEM
    
        ' Tritt auf wenn die Maus im Menü bewegt wird.
        Select Case wParam
        
        Case -1
        
            ' lParam = 0
            ' wParam = -1 Die Maus befindet sich außerhalb des Menüs.
        Case Else
        
            ' Die Maus befindet sich innerhalb des Menüs.
            ' lParam = 0
            ' wParam => 0 MenüItemPosition
        End Select
        
    Case &H1E6 'MN_???
    
        ' Tritt auf wenn ein Item im Menü mit der Maus ausgewählt wurde
        ' aber die Maustaste außerhalb des Menüs losgelassen wird.
        ' lParam = 0
        ' wParam = 0
    Case &H1ED 'MN_BUTTONDOWN
    
        ' Tritt auf wenn eine Maustaste gedrückt wird.
        ' lParam = 0
        ' wParam = MenüItemPosition
    Case &H1EF 'MN_BUTTONUP
    
        ' Tritt auf wenn eine Maustaste losgelassen wird.
        ' lParam = Mausposition auf dem Bildschirm
        ' wParam = MenüItemPosition
        Call GetSelectedMenuItem(m_MenuItemID, lParam)
    
    Case WM_KEYDOWN
    
        ' Tritt auf wenn eine Cursor-Taste gedrückt wird.
        ' lParam = 0
        ' wParam = Virtual Keycode
        If wParam = vbKeyReturn Then
        
            Call GetSelectedMenuItem(m_MenuItemID)
            
        End If
        
    Case WM_CHAR
    
        ' Tritt auf wenn eine andere Taste gedrückt wird.
        ' lParam = 0
        ' wParam = Char Code
    Case WM_SYSKEYDOWN
    
        ' Tritt auf wenn die ALT-Taste gedrückt wird.
        ' lParam = 0
        ' wParam = Virtual Keycode
    Case WM_WINDOWPOSCHANGING
    
        ' Tritt auf wenn die Große, Position oder Z-Order geändert wird
        ' lParam = Zeiger auf eine WINDOWPOS Struktur
        ' wParam = 0
    Case WM_WINDOWPOSCHANGED
    
        ' Tritt auf wenn die Große, Position oder Z-Order geändert wurde
        ' lParam = Zeiger auf eine WINDOWPOS Struktur
        ' wParam = 0
    Case WM_DESTROY
    
        ' Tritt auf wenn das Fenster zerstört wird. Hier beenden wir
        ' das Subclassing des Menüfensters.
        ' lParam = 0
        ' wParam = 0
        Call UnHookMenu
        
    Case WM_NCDESTROY
    
        ' Tritt auf wenn der NONCLIENT zerstört wird. Tritt nach
        ' WM_DESTROY auf. Da wir aber das Subclassing schon im
        ' WM_DESTROY beenden, wird diese Nachricht nicht mehr emfpangen.
        ' lParam = 0
        ' wParam = 0
    End Select
        
End Function

Friend Function ObjectMsgRec(ByVal uMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
    Dim Lo As Long
    Dim Hi As Long
    Dim bolItemDisabled As Boolean
    Dim tMII As MENUITEMINFO
    
    ObjectMsgRec = CallWindowProc(m_WndProc, m_HookWnd, uMsg, wParam, _
        lParam)
        
    Select Case uMsg
    
    Case WM_CONTEXTMENU
        
        ' Tritt auf wenn das Kontextmenü aufgerufen wird.
        ' lParam = Mausposition auf dem Bildschrim
        ' wParam = Handle vom Fenster, das das Kontextmenü aufgerufen hat.
         Call GetShort(lParam, Lo, Hi)

    Case WM_ENTERIDLE
    
        ' Tritt auf wenn das Kontextmenü nichts zu tun hat. Also
        ' wenn keine Maus- oder Tastaturaktionen durchgeführt werden.
        ' lParam = Handle vom Fenster, auf dem das Menü dargestellt wird
        ' wParam = Dialog (MSGF_DIALOGBOX) oder Menü (MSGF_MENU)
    
        ' ist es ein Menü
        If wParam = MSGF_MENU Then
            
            ' ist ein FensterHandle vorhanden
            If lParam <> 0 Then
            
                ' ist ein MenüHandle vorhanden
                If m_hMenu <> 0 Then
                
                    ' wenn das Subclassing des Menüfensters noch nicht
                    ' gestartet wurde
                    If Not m_MenuTracking Then
                    
                        ' merken das das Subclassing gestartet wird
                        m_MenuTracking = True
                        
                        ' Menüfenster subclassen
                        Call HookMenu(lParam)
                        
                    End If
                End If
            End If
        End If
        
    Case WM_MENUSELECT
        
        ' Tritt auf wenn ein Menüitem selektiert wird.
        ' lParam = Handle vom Menü
        ' wParam = MenüItemId
        
        ' ist ein MenüHandle vorhanden
        If lParam <> 0 Then
        
            ' MenüHandle speichern
            m_hMenu = lParam
            
            ' MenüItemID speichern
            m_MenuItemID = (wParam And &HFFFF&)
            
            ' MenüItemID vorhanden
            If m_MenuItemID <> 0 Then
            
                tMII.cbSize = Len(tMII)
                tMII.fMask = MIIM_STATE ' Status des MenüItems
            
                ' MenüItemInfo auslesen
                If GetMenuItemInfo(m_hMenu, m_MenuItemID, False, tMII) <> 0 Then
        
                    ' Wenn der Menüeintrag deaktiv ist
                    If (tMII.fState And MFS_DISABLED) = MFS_DISABLED Then
                    
                        ' speichern das dieser Menüpunkt deaktiv ist
                        bolItemDisabled = True
                        
                    End If
                End If
                
                ' Debug.Print "MenuHandle = &H" & Hex$(m_hMenu)
                ' Debug.Print "MenuItemId = &H" & Hex$(m_MenuItemID)
                ' Debug.Print "MenuItemDisabled = " & CStr(bolItemDisabled)
                ' Debug.Print "MenuString = " & GetMenuStringFromItemID(m_MenuItemID)
            End If
        End If
        
    End Select
    
End Function

Public Sub UnHook()

    If m_HookWnd <> 0 Then
    
        Call SetWindowLong(m_HookWnd, GWL_WNDPROC, m_WndProc)
        
        If colObject.Count = 1 Then
        
            colObject.Remove "Object" & CStr(m_HookWnd)
            
        End If
        
        m_HookWnd = 0
        
    End If
    
End Sub

Private Sub UnHookMenu()

    If m_MenuWnd <> 0 Then
    
        Call SetWindowLong(m_MenuWnd, GWL_WNDPROC, m_MenuProc)
        
        If colMenu.Count = 1 Then
        
            colMenu.Remove "Menu" & CStr(m_MenuWnd)
            
        End If
        
        m_MenuWnd = 0
        m_MenuTracking = False
        
    End If
    
End Sub

Private Sub Class_Terminate()

    Call UnHookMenu
    Call UnHook
    
End Sub


'--- Ende Klasse "clsContextMenu" alias clsContextMenu.cls  ---
'------------ Ende Projektdatei ContextMenu.vbp  ------------