Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0757: Beliebige Anzahl an Fenstern subklassifizieren

VB 5/6-Tipp 0757: Beliebige Anzahl an Fenstern subklassifizieren

 von Henrik Ilgen

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), RtlMoveMemory (CopyMemoryString), GetPropA (GetProp), RemovePropA (RemoveProp), SetPropA (SetProp), SetWindowLongA (SetWindowLong)

Download: Download des Beispielprojektes [6,11 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 MultiHook.vbp  ------------
' --------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

Private Declare Sub CopyMemoryString Lib "kernel32.dll" _
                    Alias "RtlMoveMemory" ( _
                    ByVal Destination As String, _
                    ByVal Source As Long, _
                    ByVal ByteLen As Long)
                    
Private Const WM_MOVE As Long = &H3
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_CHAR As Long = &H102
Private WithEvents mForm1Handler As cHook
Private WithEvents mForm2Handler As cHook
Private Form2Unloaded As Boolean

' Called when Form2 is closed by user input (otherwise the code would
' crash as soon as Form_Unload() is called)
'
' Wird aufgerufen, wenn Form2 durch Benutzereingabe geschlossen wird
' (ansonsten würde es im Aufruf von Form_Unload() crashen)
Public Sub UnhookForm2()

    Call mForm2Handler.UnHook
    
    Set mForm2Handler = Nothing
    
    Form2Unloaded = True
    
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)

    Debug.Print Chr$(KeyAscii)
    
End Sub

Private Sub Form_Load()

    Label1.Caption = "Zum Testen muss dieses oder das andere Fenster " & _
        "verschoben werden. Die Ereignisse werden dann im Direktfenster " & _
        "angezeigt." & vbCr & "Um das Ändern der Nachrichten zu testen, " & _
        "kann ein beliebiger Buchstabe auf der Tastatur gedrückt werden. " & _
        "Im Direktfenster erscheint dann - bedingt durch das Subclassing " & _
        "- der nachfolgende Buchstabe."
        
    Load Form2
    
    Call Form2.Show
    
    ' Initialize the hooks
    ' Die Hooks initialisieren
    Set mForm1Handler = New cHook
    Set mForm2Handler = New cHook
    
    Call mForm1Handler.Hook(Me.hWnd)
    Call mForm2Handler.Hook(Form2.hWnd)
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' UnHook Form1
    ' Den Hook auf Form1 auflösen
    Call mForm1Handler.UnHook
    
    Set mForm1Handler = Nothing
    
    ' UnHook Form2 unless this has already happened
    ' Den Hook auf Form2 auflösen, wenn dies noch nicht geschehen ist
    If Not Form2Unloaded Then
    
        Call mForm2Handler.UnHook
        
        Set mForm2Handler = Nothing
        
        Unload Form2
        
    End If
    
End Sub

Private Sub mForm1Handler_Message(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByRef wParam As Long, ByRef lParam As Long, ReturnValue As Long, _
    CallPreviousProc As Boolean)
    
    Select Case uMsg
    
    Case WM_MOVE
        Debug.Print "Form1 has been moved/Form1 wurde verschoben."
        
    Case WM_CHAR
    
        ' make an arbitrary variation
        ' When a character is entered, replace it with another one
        '
        ' Wenn ein Buchstabe eingegeben wird, durch den nächsten ersetzen
        ' Dies hat keinen Einfluss auf den Hook, es dient nur zur Anschauung.
        wParam = wParam + 1
        
    End Select
    
    ' Set CallPreviousProc to False in order to not call the original
    ' WindowProc.
    ' You do not need to set CallPreviousProc to True in order to let it be
    ' called.
    '
    ' Wird CallPreviousProc auf False gesetzt, so wird die vorherige
    ' WindowProc
    ' nicht aufgerufen. CallPreviousProc muss nicht auf True gesetzt werden.
    '
    ' CallPreviousProc = False
End Sub

Private Sub mForm2Handler_Message(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByRef wParam As Long, ByRef lParam As Long, ReturnValue As Long, _
    CallPreviousProc As Boolean)
    
    Select Case uMsg
    
    Case WM_MOVE
        Debug.Print "Form2 has been moved/Form2 wurde verschoben."
        
    End Select
    
    ' CallPreviousProc = False
End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------
' ---------- Anfang Klasse "cHook" alias cHook.cls  ----------
Option Explicit

Private Declare Function CallWindowProc Lib "user32.dll" _
                         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 SetWindowLong Lib "user32.dll" _
                         Alias "SetWindowLongA" ( _
                         ByVal hWnd As Long, _
                         ByVal nIndex As Long, _
                         ByVal dwNewLong As Long) As Long
                         
Private Declare Function SetProp Lib "user32.dll" _
                         Alias "SetPropA" ( _
                         ByVal hWnd As Long, _
                         ByVal lpString As String, _
                         ByVal hData As Long) As Long
                         
Private Declare Function GetProp Lib "user32.dll" _
                         Alias "GetPropA" ( _
                         ByVal hWnd As Long, _
                         ByVal lpString As String) As Long
                         
Private Declare Function RemoveProp Lib "user32" _
                         Alias "RemovePropA" ( _
                         ByVal hWnd As Long, _
                         ByVal lpString As String) As Long
                         
Private Const GWL_WNDPROC As Long = -4

' Raised when a message arrives
' Wird ausgelöst, wenn eine Nachricht eintrifft
Public Event Message(ByVal hWnd As Long, ByVal uMsg As Long, ByRef wParam As _
    Long, ByRef lParam As Long, ByRef ReturnValue As Long, ByRef _
    CallPreviousProc As Boolean)
    
' Has this Instance already hooked a window?
' Wurde durch diese Instanz bereits ein Fenster gehookt?
Private mHooked         As Boolean

' Handle of the hooked window
' Handle des gehookten Fensters
Private mhWnd           As Long

' Address of the original WindowProc
' Adresse der ursprünglichen WindowProc
Private mPrevWindowProc As Long

' Called when a message arrives
' Wird aufgerufen, wenn eine Nachricht eintrifft
Friend Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
    wParam As Long, ByVal lParam As Long) As Long
    
    Dim lCallPrevWndProc As Boolean: lCallPrevWndProc = True
    Dim RetVal As Long
    
    ' Tell the owner that a message arrived
    ' Den Ersteller über die Nachricht informieren
    RaiseEvent Message(hWnd, uMsg, wParam, lParam, RetVal, lCallPrevWndProc)
    
    If lCallPrevWndProc Then
    
        WindowProc = CallWindowProc(mPrevWindowProc, hWnd, uMsg, wParam, _
            lParam)
            
    Else
    
        WindowProc = RetVal
        
    End If
    
End Function

Public Function CallPrevWindowProc(ByVal uMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
    CallPrevWindowProc = CallWindowProc(mPrevWindowProc, mhWnd, uMsg, _
        wParam, lParam)
        
End Function

Public Sub Hook(ByVal hWnd As Long, Optional ByVal PropertyName As String = _
    "MHInstance")
    
    ' Unhook before hooking another window
    ' Einen eventuellen vorherigen Hook lösen, bevor ein neuer eingestellt
    ' wird
    If mHooked Then
    
        Call UnHook
        
    End If
    
    If gPropertyName = "" Then
    
        gPropertyName = PropertyName
        
    End If
    
    ' Check whether the window has already been hooked
    ' Prüfen, ob das Fenster bereits gehookt wurde
    If GetProp(hWnd, gPropertyName) <> 0 Then
    
        Call Err.Raise(vbObjectError + 3, "Hook()", sprintf("{0} has " & _
            "already been hooked.", hWnd))
            
        Exit Sub
        
    End If
    
    ' Set the window's property to a pointer to this instance
    ' Dem Fenster eine Eigenschaft mit einem Zeiger auf diese Instanz geben
    If SetProp(hWnd, gPropertyName, ObjPtr(Me)) = 0 Then
    
        Call Err.Raise(vbObjectError + 1, "Hook()", sprintf("Failed to " & _
            "set property '{0}' to {1}; Code: {2}", gPropertyName, hWnd, _
            Err.LastDllError))
            
        Exit Sub
        
    End If
    
    ' Set the new WindowProc
    ' Neue WindowProc einsetzen
    mPrevWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf _
        modAPI.WindowProc)
        
    If mPrevWindowProc = 0 Then
    
        Call Err.Raise(vbObjectError + 2, "Hook()", sprintf("Failed to " & _
            "set windowproc of {0} to {1}", hWnd, AddressOf _
            modAPI.WindowProc))
            
        Exit Sub
        
    End If
    
    mhWnd = hWnd
    mHooked = True
    
End Sub

Public Sub UnHook()

    ' Restore old WindowProc
    ' Die alte WindowProc wiederherstellen
    If SetWindowLong(mhWnd, GWL_WNDPROC, mPrevWindowProc) = 0 Then
    
        Call Err.Raise(vbObjectError + 2, "UnHook()", sprintf("Failed to " & _
            "set windowproc of {0} to {1}", mhWnd, mPrevWindowProc))
            
        Exit Sub
        
    End If
    
    ' Delete the window property containing the pointer
    ' Die Eigenschaft mit dem Zeiger löschen
    Call RemoveProp(mhWnd, gPropertyName)
    
    mhWnd = 0
    mHooked = False
    
End Sub

Private Sub Class_Terminate()

    ' Clean up before terminating
    ' Aufräumen, bevor die Instanz zerstört wird
    If mHooked Then Call UnHook
    
End Sub

' ----------- Ende Klasse "cHook" alias cHook.cls  -----------
' ---------- Anfang Modul "modAPI" alias modAPI.bas ----------
Option Explicit

Private Declare Function GetProp Lib "user32.dll" _
                         Alias "GetPropA" ( _
                         ByVal hWnd As Long, _
                         ByVal lpString As String) As Long
                         
Private Declare Sub CopyMemory Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    ByRef Destination As Any, _
                    ByRef Source As Any, _
                    ByVal ByteLen As Long)
                    
Public gPropertyName As String

' The following function was written by Bruce McKinney
Public Function PointerToObject(ByVal Pointer As Long) As Object

    Dim This As Object
    
    ' Bugfix: If Pointer = 0 is passed, CopyMemory() fails.
    '         If Pointer is 0, return Nothing
    If Pointer = 0 Then
    
        Set PointerToObject = Nothing
        
        Exit Function
        
    End If
    
    ' Turn the pointer into an illegal, uncounted interface
    CopyMemory This, Pointer, 4
    
    ' Assign to legal reference
    Set PointerToObject = This
    
    ' Destroy the illegal reference
    CopyMemory This, 0&, 4
    
End Function

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
    wParam As Long, ByVal lParam As Long) As Long
    
    Dim Pointer As Long
    Dim Instance As cHook
    
    ' Get the pointer to the instance responsible for this window
    ' Den Pointer der zuständigen Instanz für dieses Fenster ermitteln
    Pointer = GetProp(hWnd, gPropertyName)
    
    ' Get a reference from the pointer
    ' Eine Referenz aus dem Pointer ermitteln
    Set Instance = PointerToObject(Pointer)
    
    If Not Instance Is Nothing Then
    
        WindowProc = Instance.WindowProc(hWnd, uMsg, wParam, lParam)
        
    End If
    
End Function

Public Function sprintf(ByVal Expression As String, ParamArray Values() As _
    Variant) As String
    
    Dim n As Long
    
    sprintf = Replace(Expression, "{0}", Values(0))
    
    For n = 1 To UBound(Values)
    
        sprintf = Replace(sprintf, "{" & CStr(n) & "}", CStr(Values(n)))
        
    Next n
    
End Function

' ----------- Ende Modul "modAPI" alias modAPI.bas -----------
' --------- Anfang Formular "Form2" alias Form2.frm  ---------
Option Explicit

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    If UnloadMode <> vbFormCode Then
    
        Call Form1.UnhookForm2
        
    End If
    
End Sub

' ---------- Ende Formular "Form2" alias Form2.frm  ----------
' ------------- Ende Projektdatei MultiHook.vbp  -------------