Exploring the function VBA6 figured out a way to call functions the pointer.
It's simple. Declare a function prototype (void function), where the first argument will be further transferred to the function address. Next, do a patch, so he tossed to us at the address specified in the first parameter. Thus it is possible to call functions in the standard modules, class modules, forms, API-functions (eg obtained through LoadLibrary and GetProcAddress).* One note, run the project through Ctrl + F5. And working in the IDE and compiled form.
For "patching" the prototype I made a separate module:
Example call normal functions in a standard module:
Example API calls at getting through GetProcAddress:
Example call class methods on the pointer:
.bas module:
Class module:
Good luck!
CallPointer.zip
It's simple. Declare a function prototype (void function), where the first argument will be further transferred to the function address. Next, do a patch, so he tossed to us at the address specified in the first parameter. Thus it is possible to call functions in the standard modules, class modules, forms, API-functions (eg obtained through LoadLibrary and GetProcAddress).* One note, run the project through Ctrl + F5. And working in the IDE and compiled form.
For "patching" the prototype I made a separate module:
Code:
Option Explicit
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 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 FunctionCode:
' Пример вызова обычных функции по указателю
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 SubCode:
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) 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
' Пример вызова WinApi функций по указателю
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.bas module:
Code:
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
' Пример вызова методов объекта по указателю
Public Sub Main()
Dim IUnk As Long
Dim lpProp As Long
Dim lpView As Long
Dim Obj1 As clsTest
Dim Obj2 As clsTest
Dim ret As Long
Set Obj1 = New clsTest
Set Obj2 = New clsTest
GetMem4 ByVal ObjPtr(Obj1), IUnk
GetMem4 ByVal IUnk + &H1C, lpProp
GetMem4 ByVal IUnk + &H20, lpView
PatchFunc "clsTest_PropLet", AddressOf clsTest_PropLet
PatchFunc "clsTest_View", AddressOf clsTest_View
clsTest_PropLet lpProp, Obj1, 1234
clsTest_PropLet lpProp, Obj2, 9876
clsTest_View lpView, Obj1, ret
Debug.Print ret
clsTest_View lpView, Obj2, ret
Debug.Print ret
End Sub
' Прототип функций
Private Function clsTest_PropLet(ByVal Addr As Long, ByVal Obj As clsTest, ByVal Value As Long) As Long
End Function
Private Function clsTest_View(ByVal Addr As Long, ByVal Obj As clsTest, ret As Long) As Long
End FunctionCode:
Option Explicit
Dim mValue As Long
Public Property Let Prop(ByVal Value As Long)
mValue = Value
End Property
Public Function View() As Long
View = MsgBox(mValue, vbYesNoCancel)
End FunctionCallPointer.zip