Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0692: CallWindowProc mit beliebig vielen Parametern

VB 5/6-Tipp 0692: CallWindowProc mit beliebig vielen Parametern

 von Claus von der Burchard

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), FreeLibrary, GetProcAddress, LoadLibraryA (LoadLibrary)

Download: Download des Beispielprojektes [3,14 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 Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Declare Function FreeLibrary Lib "kernel32" ( _
                         ByVal hLibModule As Long) As Long
                         
Private Declare Function LoadLibrary Lib "kernel32" _
                         Alias "LoadLibraryA" ( _
                         ByVal lpLibFileName As String) As Long
                         
Private Declare Function GetProcAddress Lib "kernel32" ( _
                         ByVal hModule As Long, _
                         ByVal lpProcName As String) As Long
                         
Private Declare Function CallWindowProc Lib "user32" _
                         Alias "CallWindowProcA" ( _
                         ByRef lpPrevWndFunc As Long, _
                         ByVal hWnd As Long, _
                         ByRef Msg As Any, _
                         ByVal wParam As Any, _
                         ByVal lParam As Any) As Long

Private Sub Command1_Click()
    ' Weitere Testaufrufe '
    Dim lb As Long, pa As Long
    lb = LoadLibrary("kernel32")
    pa = GetProcAddress(lb, "Sleep")

    Call CallWindowProcVarArgs(pa, 100)
    
    pa = GetProcAddress(lb, "Beep")
    Call CallWindowProcVarArgs(pa, 440, 500)

    Call FreeLibrary(lb)
End Sub

Private Sub Form_Load()

    Dim lb As Long, pa As Long
    lb = LoadLibrary("user32")
    pa = GetProcAddress(lb, "SetWindowTextA")

    Call CallWindowProcVarArgs(pa, Me.hWnd, "CallWindowProcVarArgs")
    
    Call FreeLibrary(lb)
End Sub

Private Function CallWindowProcVarArgs(Address As Long, _
    ParamArray VarArgs() As Variant) As Long
    
    Dim Args()  As Long
    Dim UBnd    As Long
    Dim I1      As Integer
    
    ' ASM Quellcode '
    Static asm(6) As Long

    If asm(0) = 0 Then
        asm(0) = &H8BEC8B55:  asm(1) = &H5D8B0C4D:  asm(2) = &H744B4310
        asm(3) = &H50018B08:  asm(4) = &HEB04C183:  asm(5) = &H855FFF5
        asm(6) = &H10C2C9
    End If

    ' Ist der Array dimensioniert? '
    On Error Goto NoArgs
    UBnd = VarArgs(0)
    On Error Goto 0
    
    ' Es gibt mindestens 1 Argument '
    ' Alle Argumente werden verkehrtherum in einen Long-Array geladen '
    
    UBnd = UBound(VarArgs)
    
    ReDim Args(UBnd)
    For I1 = 0 To UBnd
        Select Case VarType(VarArgs(I1))
            Case vbLong, vbInteger, vbByte
                Args(UBnd - I1) = VarArgs(I1)
            Case vbString
                Args(UBnd - I1) = StrPtr(StrConv(VarArgs(I1), vbFromUnicode))
            Case Else
                Args(UBnd - I1) = VarPtr(VarArgs(I1))
        End Select
    Next
    
    ' Die Funktion wird per ASM aufgerufen '
    CallWindowProcVarArgs = CallWindowProc(asm(0), Address, Args(0), UBnd + 1, ByVal 0&)
    
    Exit Function
    
NoArgs:
    ' Der Array ist nicht dimensioniert; es gibt also überhaupt keine Argumente! '
    CallWindowProcVarArgs = CallWindowProc(asm(0), Address, 0, ByVal 0&, ByVal 0&)

End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------