Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0715: Funktionen umleiten

VB 5/6-Tipp 0715: Funktionen umleiten

 von Arne Elster

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMemory), RtlFillMemory (FillMemory), GetModuleHandleA (GetModuleHandle), GetProcAddress, IsBadCodePtr, LoadLibraryA (LoadLibrary), MessageBoxA, VirtualAlloc, VirtualFree, VirtualProtect

Download: Download des Beispielprojektes [4,96 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 "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "lblWAsm"
' Steuerelement: Beschriftungsfeld "lblWOAsm"
Option Explicit

Private Declare Function MessageBoxA Lib "user32" ( _
    ByVal hwnd As Long, ByVal strMsg As String, _
    ByVal strTitle As String, ByVal style As Long _
) As Long

Private m_udtMsgBoxAHook As HookData

Private Sub Command1_Click()
    Dim udtHook As HookData
    Dim udtAsm  As MachineCode
    
    Const iters As Long = 1000000
    
    Dim i       As Long
    Dim x       As Long
    Dim y       As Long
    Dim d       As Double
    
    Command1.Enabled = False
    
    ' Optimierter Maschinencode für Shift Left
    udtAsm = QuickHook.ASMStringToMemory("8B4424048B4C2408D3E0C20800")
    
    ' Unoptimierte VB SHL Funktion testen
    d = Timer
    Do
        x = ShiftLeft(2, 8)
        i = i + 1
    Loop While Timer - d < 1
    lblWOAsm.Caption = "ohne asm: " & i & " Calls/Sekunde"
    
    ' Umleitung in VB Funktion auf eigenen Maschinencode
    udtHook = QuickHook.RedirectFunction(AddressOf ShiftLeft, True, udtAsm.pAsm)
    
    ' Optimierte SHL Funktion testen
    d = Timer
    i = 0
    Do
        y = ShiftLeft(2, 8)
        i = i + 1
    Loop While Timer - d < 1
    lblWAsm.Caption = "mit asm: " & i & " Calls/Sekunde"
    ' Für zusätzliche Geschwindigkeit zu N-Code kompilieren,
    ' dann fällt der VB Stub vor dem Hook weg
    
    Debug.Print "VBSHL(2,8)=" & x, "ASMSHL(2,8)=" & y
    
    ' VB Funktion wiederherstellen und Maschinencodespeicher freigeben
    If Not RestoreFunction(udtHook) Then Debug.Print "RestoreFunction fehlgeschlagen!"
    If Not FreeASMMemory(udtAsm) Then Debug.Print "Konnte ASM Speicher nicht freigeben!"
    
    Command1.Enabled = True
End Sub

Private Sub Command2_Click()
    If Command2.Tag = "" Then
        ' user32.MessageBoxA auf TestModule.MessageBoxAHook umleiten
        m_udtMsgBoxAHook = RedirectFunction(GetWinAPIFunction("user32", "MessageBoxA"), _
                                            False, AddressOf TestModule.MessageBoxAHook)
        
        If Not m_udtMsgBoxAHook.valid Then
            MsgBox "Hook fehlgeschlagen!", vbExclamation
        Else
            Command2.Tag = "h"
            Command2.Caption = "MessageBoxA enthooken"
        End If
    Else
        If Not RestoreFunction(m_udtMsgBoxAHook) Then
            MsgBox "Hook konnte nicht entfernt werden!", vbRetryCancel
        Else
            Command2.Tag = ""
            Command2.Caption = "MessageBoxA hooken"
        End If
    End If
End Sub

Private Sub Command3_Click()
    Debug.Print "MsgBoxA Result: " & MessageBoxA(0, "test msg", "titel", vbInformation)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If m_udtMsgBoxAHook.valid Then
        RestoreFunction m_udtMsgBoxAHook
    End If
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------- Anfang Modul "QuickHook" alias QuickHook.bas -------
Option Explicit

Public Type HookData
    pFunction   As Long     ' Pointer zur umzuleitenden Stelle
    pNewFnc     As Long     ' Umleitungsziel
    cHookSize   As Long     ' Größe des Hooks
    pBackup     As Long     ' Pointer zu gesicherten Bytes
    cBackupSize As Long     ' Menge an gesicherten Bytes
    valid       As Boolean  ' Hook funktional?
End Type

Public Type MachineCode
    pAsm        As Long     ' Pointer zum Code
    cSize       As Long     ' Größe des Codes in Bytes
    valid       As Boolean  ' gültig?
End Type

Private Declare Function VirtualAlloc Lib "kernel32" ( _
    lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long _
) As Long

Private Const MEM_COMMIT                As Long = &H1000

Private Declare Function VirtualFree Lib "kernel32" ( _
    lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long _
) As Long

Private Const MEM_DECOMMIT              As Long = &H4000

Private Declare Function VirtualProtect Lib "kernel32" ( _
    lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal flNewProtect As Long, _
    ByRef lpflOldProtect As Long _
) As Long

Private Const PAGE_EXECUTE              As Long = &H10
Private Const PAGE_EXECUTE_READ         As Long = &H20
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    pDst As Any, pSrc As Any, ByVal cBytes As Long _
)

Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" ( _
    pDst As Any, ByVal cBytes As Long, ByVal char As Byte _
)

Private Declare Function IsBadCodePtr Lib "kernel32" ( _
    ByVal addr As Long _
) As Long

Private Const IDE_ADDROF_REL            As Long = 22
Private Const ASMSIZE                   As Long = 5

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" ( _
    ByVal strPath As String _
) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
    ByVal strModule As String _
) As Long

Private Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hModule As Long, ByVal strName As String _
) As Long

Public Function GetWinAPIFunction(ByVal strLib As String, ByVal strFncName As String) As Long
    Dim hModule As Long
    
    hModule = GetModuleHandle(strLib)
    If hModule = 0 Then
        hModule = LoadLibrary(strLib)
        If hModule = 0 Then Exit Function
    End If
    
    GetWinAPIFunction = GetProcAddress(hModule, strFncName)
End Function

' alloziert ausführbaren Speicher und schreibt
' als Hex String übergebenen Maschinencode hinein
Public Function ASMStringToMemory(ByVal strAsm As String) As MachineCode
    Dim btAsm() As Byte
    Dim i       As Long
    Dim udtMem  As MachineCode
    
    ReDim btAsm(Len(strAsm) \ 2 - 1) As Byte

    For i = 0 To Len(strAsm) \ 2 - 1
        btAsm(i) = CByte("&H" & Mid$(strAsm, i * 2 + 1, 2))
    Next

    With ASMStringToMemory
        .cSize = UBound(btAsm) + 1
        .pAsm = VirtualAlloc(ByVal 0&, .cSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
        If .pAsm <> 0 Then
            CopyMemory ByVal .pAsm, btAsm(0), .cSize
            .valid = True
        End If
    End With
End Function

Public Function FreeASMMemory(asm As MachineCode) As Boolean
    If asm.valid Then
        asm.valid = False
        FreeASMMemory = VirtualFree(ByVal asm.pAsm, asm.cSize, MEM_DECOMMIT) <> 0
    End If
End Function

' Mit Jmp Instruktion überschriebene Funktion wiederherstellen
Public Function RestoreFunction(hook As HookData) As Boolean
    Dim lngOldProtection    As Long
    Dim lngRet              As Long
    
    If hook.valid Then
        lngRet = VirtualProtect(ByVal hook.pFunction, hook.cHookSize, _
            PAGE_EXECUTE_READWRITE, lngOldProtection)
        
        If lngRet = 0 Then Exit Function
        
        CopyMemory ByVal hook.pFunction, ByVal hook.pBackup, ByVal hook.cBackupSize
        
        VirtualProtect ByVal hook.pFunction, hook.cHookSize, lngOldProtection, 0&
        VirtualFree ByVal hook.pBackup, hook.cBackupSize, MEM_DECOMMIT
        
        hook.valid = False
        RestoreFunction = True
    End If
End Function

' Funktion mit Jmp Instruktion überschreiben,
' mit Unterstützung für VB 6 IDE
Public Function RedirectFunction(ByVal addr_in As Long, ByVal isVBModule As Boolean, _
    ByVal addr_out As Long) As HookData
    
    Dim lngBackupMemory     As Long
    Dim lngOldInProtection  As Long
    Dim lngRet              As Long
    Dim lngJmp              As Long
    Dim btAsm(ASMSIZE - 1)  As Byte
    
    If isVBModule Then addr_in = VBGetFunctionPointer(addr_in)
    
    lngBackupMemory = VirtualAlloc(ByVal 0&, ASMSIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    If lngBackupMemory = 0 Then Exit Function
    
    lngRet = VirtualProtect(ByVal addr_in, ASMSIZE, PAGE_EXECUTE_READWRITE, lngOldInProtection)
    If lngRet = 0 Then
        VirtualFree ByVal lngBackupMemory, ASMSIZE, MEM_DECOMMIT
        Exit Function
    End If
    
    CopyMemory ByVal lngBackupMemory, ByVal addr_in, ASMSIZE
    
    lngJmp = addr_out - addr_in - ASMSIZE
    
    btAsm(0) = &HE9
    CopyMemory btAsm(1), lngJmp, 4
    
    CopyMemory ByVal addr_in, btAsm(0), ASMSIZE
    
    lngRet = VirtualProtect(ByVal addr_in, ASMSIZE, lngOldInProtection, 0&)
'    If lngRet = 0 Then
'        VirtualFree ByVal lngBackupMemory, ASMSIZE, MEM_DECOMMIT
'        Exit Function
'    End If
    
    With RedirectFunction
        .pFunction = addr_in
        .pNewFnc = addr_out
        .pBackup = lngBackupMemory
        .cBackupSize = ASMSIZE
        .cHookSize = ASMSIZE
        .valid = True
    End With
End Function

Private Function VBGetFunctionPointer(ByVal addrof As Long) As Long
    Dim pAddr As Long
    
    If IsRunningInIDE_DirtyTrick() Then
        ' Wird das Programm aus der Entwicklungsumgebung heraus
        ' ausgeführt, befindet sich der eigentliche Zeiger auf
        ' eine Funktion bei (AddressOf X) + 22, AddressOf X
        ' selber zeigt nur auf einen Stub. (getestet mit VB 6)
        CopyMemory pAddr, ByVal addrof + IDE_ADDROF_REL, 4
        If IsBadCodePtr(pAddr) <> 0 Then pAddr = addrof
    Else
        pAddr = addrof
    End If
    
    VBGetFunctionPointer = pAddr
End Function

' http://www.activevb.de/tipps/vb6tipps/tipp0347.html
Private Function IsRunningInIDE_DirtyTrick() As Boolean
  On Error Goto NotCompiled
  
    Debug.Print 1 / 0
    Exit Function
    
NotCompiled:
    IsRunningInIDE_DirtyTrick = True
    Exit Function
End Function
'-------- Ende Modul "QuickHook" alias QuickHook.bas --------
'------- Anfang Modul "TestModule" alias Module1.bas  -------
Option Explicit

Private m_lngShift(31) As Long
Private i              As Long

' VB behandelt lngIn als vorzeichenbehaftet.
' Der ASM Code, mit dem die Funktion überschrieben wird,
' interpretiert lngIn dagegen als unsigned.
Public Function ShiftLeft(ByVal lngIn As Long, ByVal lngBits As Long) As Long
    If m_lngShift(0) = 0 Then
        m_lngShift(0) = 1
        For i = 1 To 30
            m_lngShift(i) = m_lngShift(i - 1) * 2
        Next
        m_lngShift(i) = &H80000000
    End If
    
    ShiftLeft = lngIn * m_lngShift(lngBits)
End Function

Public Function MessageBoxAHook(ByVal hwnd As Long, ByVal msg As Long, _
    ByVal title As Long, ByVal style As Long) As Long
    
    MessageBoxAHook = MsgBox("Gehookt!", style, "Am Haken")
End Function
'-------- Ende Modul "TestModule" alias Module1.bas  --------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.