Вызов любых функций по указателю - VB

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Sub EbGetExecutingProj Lib "vba6" (hProject As Long)
Private Declare Function TipGetFunctionId Lib "vba6" (ByVal hProj As Long, ByVal bstrName As Long, ByRef bstrId As Long) As Long
Private Declare Function TipGetLpfnOfFunctionId Lib "vba6" (ByVal hProject As Long, ByVal bstrId As Long, ByRef lpAddress As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal lpbstr As Long)
 
Private Const PAGE_EXECUTE_READWRITE = &H40
 
' Пример вызова функции по указатею
Public Sub Main()
 
    ' Пропатчиваем функции, перед первым вызовом
    PatchFunc "Proto1", AddressOf Proto1
    PatchFunc "Proto2", AddressOf Proto2
 
    MsgBox Proto1(AddressOf Func1, 1, "Вызов")
    MsgBox Proto1(AddressOf Func2, 2, "По указателю")
    MsgBox Proto1(AddressOf Func3, 3, ";)")
 
    Call Proto2(AddressOf Sub1)
    Call Proto2(AddressOf Sub2)
End Sub
 
' Прототип функций
Private Function Proto1(ByVal Addr As Long, ByVal x As Long, y As String) As String
End Function
Private Sub Proto2(ByVal Addr As Long)
End Sub
' Функции
Private Function Func1(ByVal x As Long, y As String) As String
    Func1 = "Func1_" & y
End Function
Private Function Func2(ByVal x As Long, y As String) As String
    Func2 = "Func2_" & y
End Function
Private Function Func3(ByVal x As Long, y As String) As String
    Func3 = "Func3_" & y
End Function
Private Sub Sub1()
    MsgBox "Sub1"
End Sub
Private Sub Sub2()
    MsgBox "Sub2"
End Sub
 
' Вспомогательные функции
Private Sub PatchFunc(FuncName As String, ByVal Addr As Long)
    Dim lpAddr As Long, hProj As Long, sId As Long, InIDE As Boolean
 
    Debug.Assert MakeTrue(InIDE)
 
    ' Получаем адрес функции
    If InIDE Then
        EbGetExecutingProj hProj
        TipGetFunctionId hProj, StrPtr(FuncName), sId
        TipGetLpfnOfFunctionId hProj, sId, lpAddr
        SysFreeString sId
    Else
        lpAddr = GetAddr(Addr)
        VirtualProtect lpAddr, 8, PAGE_EXECUTE_READWRITE, 0
    End If
 
    ' Записываем вставку
    ' Запускать только по Ctrl+F5!!
    ' pop eax
    ' pop ecx
    ' push eax
    ' jmp ecx
 
    GetMem4 &HFF505958, ByVal lpAddr
    GetMem4 &HE1, ByVal lpAddr + 4
End Sub
 
Private Function GetAddr(ByVal Addr As Long) As Long
    GetAddr = Addr
End Function
Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
    bvar = True: MakeTrue = True
End Function

' Пример вызова метода по указатею
Public Sub Main()
    Dim lpFunc As Long, Obj As Class1, ret As Long
 
    Set Obj = New Class1
 
    GetMem4 ByVal ObjPtr(Obj), lpFunc
    GetMem4 ByVal lpFunc + &H1C, lpFunc
 
    PatchFunc "Class1_ZZZ", AddressOf Class1_ZZZ
 
    Call Class1_ZZZ(lpFunc, Obj, 123, 567, ret)
End Sub
 
' Прототип функций
Private Function Class1_ZZZ(ByVal Addr As Long, ByVal Obj As Class1, ByVal o As Long, ByVal b As Long, ret As Long) As Long
End FunctionPublic Function ZZZ(ByVal o As Long, ByVal b As Long) As Long
    MsgBox o & " " & b
    ZZZ = 5
End Function

' Пример вызова метода по указатею
Public Sub Main()
    Dim hUser As Long, hGDI As Long
    Dim DC As Long
 
    hUser = LoadLibrary("user32")
    hGDI = LoadLibrary("gdi32")
 
    PatchFunc "GetDC", AddressOf GetDC
    PatchFunc "ReleaseDC", AddressOf ReleaseDC
    PatchFunc "Ellipse", AddressOf Ellipse
 
    DC = GetDC(GetProcAddress(hUser, "GetDC"), 0)
    Ellipse GetProcAddress(hGDI, "Ellipse"), DC, 0, 0, 500, 500
    ReleaseDC GetProcAddress(hUser, "ReleaseDC"), 0, DC
End Sub
 
' Прототип функций
Private Function GetDC(ByVal Addr As Long, ByVal hWnd As Long) As Long
End Function
Private Function ReleaseDC(ByVal Addr As Long, ByVal hWnd As Long, ByVal hdc As Long) As Long
End Function
Private Function Ellipse(ByVal Addr As Long, ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
End Function