-
API CallBacks Using an Object's Procedure
API CallBacks Using an Object's Procedure
Attributions: Huge thanks goes out to The Trick, Wqweto, Dz32, Fafalone, and LaVolpe. They all provided insights, inspiration, and code toward what you see in this thread.
Prerequisite: It's assumed you know what an API CallBack is. If not, you really don't have to worry about any of this.
A bit on nomenclature: I tend to use "method" and "procedure" synonymously. I also tend to use "properties" and "public variables" as somewhat synonymous. If I want to talk about "methods" and "properties" together, I'll use the term "members". I also tend to use "argument" and "parameter" as synonymous.
--------------------------
This has been done before, and this is just my version of it. Also, I've documented it extensively so that anyone who's interested should be able to "think through" everything I've done.
Just to say it, it's a lot of code for a sort of small thing. I mean, we can always put our CallBacks in BAS modules, and they work just fine. But this is something I've wanted for years, so that I can create object modules (Classes, Forms, UserControls, PropertyPages, & DataReports) that use CallBacks that are all wrapped into their respective code areas.
This can also be used for subclassing, but that's not what it is. If you think about it, all subclassing does is make a "CallBack" with everything that's coming through the message pump for any particular window.
Also, just to try and eliminate confusion, I'm talking about a specific VB6 project and it's associated source code (and those source code objects). I'm not talking about referenced DLLs (ActiveX or otherwise). Some of this code could be used for those things, but that's not what this thread is about.
Downsides to the way I've done it:
- There's no IDE protection. But that's only a problem if you try to trace through the CallBack procedure and/or put breakpoints in it. Otherwise, everything should be fine regarding the rest of your code. Again, this isn't subclassing, but it could be used for subclassing. When used with subclassing, those other uses could provide IDE protection. That's up to the subclassing, and not these routines.
- I've limited the CallBack function to being a "Function" (no Subs, nor Properties), and it must have 1, 2, 3, or 4 arguments. Furthermore, those arguments must be either ByRef or 4-byte ByVal arguments. And the return must also be 4-bytes (preferably a Long). But this covers the vast majority of Microsoft API CallBacks.
- I haven't tested an object that has another object "Implemented". As soon as I get that tested, I'll report back on that one.
Upsides to the way I've done it:
- There's no modification to the actual code of the object. Basically, all of this is just a "wrapper" that turns a call for a standard BAS procedure into a call for a COM (object) procedure. But that's much easier said than done.
- It's (hopefully) extremely well documented so that anyone who wants to use it can see precisely what's going on.
- It works equally well when running in the IDE or compiled as either p-code or machine code.
- There's no special order in which the CallBack procedures need to appear in your code.
The challenges. There were many, but I'll go through them one-by-one, providing solutions for each as we go. And later on, I'll provide a few projects with complete examples that you could use to "mold" into your own uses and applications.
Challenge #1: Are we dealing with a VB6 object that has code, or some other kind of object?
In many of the procedures herein, an object is passed in. I didn't want to have any problems if someone tried to pass in a non-code object (such as a StdFont, StdPicture, or Collection object, etc., etc.). I also wanted to assure that the object was instantiated.
This problem is solved with the following function and API call: (Specific thanks to The Trick & Wqweto for this.)
Code:
Private Declare Function vbaCheckType Lib "msvbvm60" Alias "__vbaCheckType" (ByVal pObj As Any, ByRef pIID As Any) As Boolean
Public Function ObjectIsVb6ComCodeModule(ByRef o As IUnknown) As Boolean
' If it's an instantiated Class, Form, UC, PropPage, DataReport, returns TRUE, else FALSE.
If ObjPtr(o) = 0& Then Exit Function ' Make sure "something" is instantiated.
Dim aGUID(1&) As Currency ' Just to get 16 easily accessible bytes.
aGUID(0&) = 128347367577987.1845@ ' Const AreYouABasicInstance As String = "{0B6C9465-D082-11CF-8B4F-00A0C90F2704}"
aGUID(1&) = 29922525889064.5387@ ' turned into two numbers stuffed into our Currency array.
ObjectIsVb6ComCodeModule = vbaCheckType(o, aGUID(0)) ' Check and see if we are this "TYPE" (Class, Form, UC, PropPage, or DataRep).
End Function
Challenge #2: The AddressOf operator doesn't work on object procedures. Therefore, we've got to figure out how to get the address of procedures in our object's code. This immediately takes us to a discussion of vTables. A vTable is nothing but a list of addresses. These are all the memory addresses of all the procedures in our object's code. All VB6 objects contain "interface" procedures for the IUnknown and IDispatch procedures (3 for IUnknown and 4 for IDispatch), but we really don't need to worry about those. All but CLS based objects also have "hidden" procedures that are placed in by VB6 to make the object "work". Fortunately, we don't have to worry about those either. Following those, there are two more groups of procedures in an object's vTable: 1) Public procedures (including Get/Let/Set procedures built for Public variables) that we've coded, and 2) Private/Friend procedures that we've coded.
(Just to note, Private variables aren't in the vTable, and the compiler makes no distinction between Private or Friend procedures with respect to the vTable. Also, in terms of the vTable, there's no distinction between events and all other procedures. If you code up an event, it's in the vTable.)
So, our challenge #2 transforms into figuring out which address in the vTable is pointing toward our desired CallBack procedure. This basically breaks down into two parts: 1) getting the address of the vTable, and 2) getting an offset into the vTable for our CallBack procedure. Getting the address of any vTable is easy:
Code:
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable ' Get pointer to start of vTable.
Now, we just need to get our offset for the vTable's address that we actually want. I tried several approaches (some of which I'll discuss later on), but I finally settled on one that I particularly like. Supply it the object, and the procedure name, and it returns the vTable offset as well as the number of arguments passed into the procedure. Here it is: (Thanks to The Trick & Dz32 on this one.)
Code:
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByRef lpString As Any) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByRef psz As Any, ByVal lSize As Long) As String
Public Function VtableOffsetForVb6ComMethod(ByVal o As Object, ByVal sMethodName As String, Optional ByRef lArgCount As Long) As Long
' Searches PUBLIC methods. It "could" find Private & Friend, but only in the IDE, not compiled.
' Does NOT search properties (i.e., Public variables or Get/Let/Set procedures).
' Returns an OFFSET address ready to be added to the vTable address.
' Optional bbArgCount return is a count of passed in arguments.
' ByRef/ByVal doesn't matter, and TYPE doesn't matter.
' If it's a Function the return isn't counted.
'
' If it can't be found, ZERO is returned.
'
If Not ObjectIsVb6ComCodeModule(o) Then Exit Function ' Make sure we're dealing with a VB6 COM-code object.
sMethodName = UCase$(sMethodName)
'
Dim pVTbl As Long: GetMem4 ByVal ObjPtr(o), pVTbl ' Pointer to vTable.
Dim pObjInfo As Long: GetMem4 ByVal pVTbl - 4&, pObjInfo ' Pointer to tObjectInfo structure.
Dim pPubDesc As Long: GetMem4 ByVal pObjInfo + &H18&, pPubDesc ' tObjectInfo.aObject which points to tObject structure.
Dim pPrivDesc As Long: GetMem4 ByVal pObjInfo + &HC&, pPrivDesc ' tObjectInfo.lpPrivateObject which points to tPrivateObj structure.
'
If pPrivDesc = 0& Then Exit Function ' Just a double-check.
'
Dim lIndex As Long
Dim pName As Long
'
' Search the procedures within the module.
Dim pMethDesc As Long
Dim iMethOffset As Integer
Dim bbArgs As Byte
Dim lMethodsCnt As Long: GetMem2 ByVal pPubDesc + &H1C&, lMethodsCnt ' tObject.ProcCount value.
Dim pNames As Long: GetMem4 ByVal pPubDesc + &H20&, pNames ' tObject.aProcNamesArray which points to an array of name pointers.
Dim pMethodsPtr As Long: GetMem4 ByVal pPrivDesc + &H18&, pMethodsPtr ' tPrivateObj.lpFuncTypeInfo which points to an array of pointers.
'
' Loop through methods and see if we can find the one we want.
For lIndex = 0& To lMethodsCnt - 1&
GetMem4 ByVal pMethodsPtr + lIndex * 4&, pMethDesc ' From the array, getting a pointer to a method structure (tMethInfo).
If pMethDesc Then ' Not sure if this ever returns zero, maybe for "Private" methods?
GetMem2 ByVal pMethDesc + 2&, iMethOffset ' Out of tMethInfo structure.
GetMem1 ByVal pMethDesc, bbArgs ' First two bits of bbArgs are: set=3, get=1, let=2, method=0 (Sub or Fn).
If (bbArgs And CByte(3)) = CByte(0) Then ' Make sure it's a method.
If iMethOffset And 1 Then ' First bit, 1=Public.
GetMem4 ByVal pNames + lIndex * 4&, pName ' Dig pointer to method name from array of name pointers.
If sMethodName = UCase$(SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))) Then
VtableOffsetForVb6ComMethod = CLng(iMethOffset And &HFFFC) ' First two bits are something else (first is Public=1,Private=0).
Dim bbFlags As Byte: GetMem1 ByVal pMethDesc + 1&, bbFlags ' Both bbArgs & bbFlags out of tMethInfo structure.
bbFlags = bbFlags And CByte(1) ' 0 (no return), 1 (return).
lArgCount = CLng(bbArgs \ CByte(4) - bbFlags) ' Calculate arguments, excluding any return argument. Tested for vbGet, vbLet, vbSet, vbMethod (both Function & Sub).
Exit Function
End If
End If
End If
End If
Next
'
' Return zero if not found.
End Function
This VtableOffsetForVb6ComMethod uses the above ObjectIsVb6ComCodeModule call, which is absolutely essential for what this VtableOffsetForVb6ComMethod does. I've documented this as best I could. It's essentially digging into compiled structures of any VB6 COM object. I've tried to identify these structures as I dig through them as best I can, and there is some (limited) documentation out on the web regarding these. Basically, the code is figuring out whether the procedures are Public vs Private, what type they are (Sub, Function, Property), what their name is, and how many arguments into it there are. But the main thing we're after is the vTable offset, and that's the return value (if the procedure is found).
Note that this only works for Public procedures. Below, I'll discuss an alternative approach that can be taken if we'd like to keep our CallBack procedures Private.
-
Re: API CallBacks Using an Object's Procedure
So, from where we are now, we can write the following function:
Code:
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Public Function Vb6ComCodeObjectAddressOf(ByVal o As Object, ByVal sMethodName As String, Optional ByRef lArgCount As Long) As Long
' lArgCount is an optional RETURN. ByRef/ByVal doesn't matter, and TYPE doesn't matter. If it's a Function the return isn't counted.
' The caller is responsible for knowing how to use the returned address, or crash may result.
' See more notes within VtableOffsetForVb6ComMethod procedure.
'
' Returns ZERO if not found, or it's not a PUBLIC method.
'
lArgCount = 0& ' Zero out anything there to start.
Dim iVoffset As Long: iVoffset = VtableOffsetForVb6ComMethod(o, sMethodName, lArgCount)
If iVoffset = 0& Then Exit Function ' This checks to make sure the object is okay.
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable ' Get pointer to start of vTable.
pVtable = pVtable + iVoffset ' Address to our method in the vTable.
GetMem4 ByVal pVtable, Vb6ComCodeObjectAddressOf ' Pointer into actual code (the method).
End Function
And this is basically the same thing as the AddressOf operator, but it works for any of the VB6 COM/code objects. One might think that we're home free after this, but we're actually far from it. VB6 COM/code procedures have "under the hood" stuff that BAS procedures don't have. And if we attempt to use this Vb6ComCodeObjectAddressOf for a CallBack address, we'll just crash.
Challenge #3: Making a procedure in a VB6 object "look like" a regular BAS procedure.
In a BAS procedure, what you see is what you get. However, that's not true for a COM procedure. Let's take an example to illustrate. Here's a typical BAS procedure that might be used as a CallBack:
Code:
Public Function EnumResNameProc(ByVal hModule As Long, _
ByVal lpszType As Long, _
ByVal lpszName As Long, _
ByVal lParam As Long) As Long
We might think that we can copy-paste that Function declaration and place it into an object, and we certainly can. However, when we do that, it's no longer "what you see is what you get". Putting it into a COM object adds an argument onto the left, and also rearranges the return. When placed into a COM object, here's what it looks like "under the hood":
Code:
Public Function EnumResNameProc(ByVal ObjPtrValue As Long, _
ByVal hModule As Long, _
ByVal lpszType As Long, _
ByVal lpszName As Long, _
ByVal lParam As Long, _
ByRef OurReturn As Long) As Long ' Returns API HRESULT value.
So, we can begin to see why we'd crash if we called this as if it were a regular BAS procedure. Furthermore, that ObjPtrValue argument MUST be a valid instantiated pointer, or we'll crash. Basically, when calling an object, it always needs to know where to find its instantiated module-level variables and any Static variables. And that's true even if we don't use them. That's what the ObjPtrValue is used for.
So, there's just no way around this without writing a bit of assembly language code (a "thunk"), and that's what I've done. I wrote it in such a way that it's a "wrapper" for any specific COM procedure, requiring that COM procedure's address and how many arguments are being passed. It always assumes it's a Function. The actual assembly code gets patched up for three things: 1) our ObjPtr value, 2) our procedure's address (from Vb6ComCodeObjectAddressOf), and 3) the number of arguments in the COM procedure. It also rearranges the stack to accept what would normally be on a BAS call's stack and makes it look like what should be on a COM call's stack. Here it is: (LaVolpe's & Wqweto's code were my inspiration for getting this sorted.)
Code:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Public Function AddressOfThunkForComProc(ByVal o As Object, _
ByVal ComProcAddress As Long, _
ByVal ComProcArgCount As Long, _
ByRef iThunkSize As Long) As Long
' This makes a thunk and places it into a Byte array.
' This thunk is specifically for allowing COM procedures to be called as standard BAS procedures.
'
' ComProcAddress: The actual address of the COM procedure, typically dug out of the vTable.
'
' ComObjPtr: Usually comes out of ObjPtr(TheObject) for an instantiated VB6 COM/Code object (Form, Class, UC, PropertyPage, or DataReport).
'
' ComProcArgCount: The number of arguments "seen" in the code of the COM procedure.
' It's MANDATORY that this be a number from 1 to 4 !!!!
' It is assumed all the arguments are either ByRef or 4-byte ByVal arguments.
' Anything else will fail and probably cause a crash.
'
' iThunkSize: Returned, and it must be used with VirtualFree to free this thunk memory.
' The FreeTheThunk procedure is setup for this.
'
If ComProcAddress = 0& Or ObjPtr(o) = 0& Then Exit Function
If ComProcArgCount < 1& Or ComProcArgCount > 4& Then Exit Function
Dim bb() As Byte
'
' Auto generated by Elroy's thunk maker.
ReDim bb(44)
' ;
' ; The idea here is to convert a call that thinks it's a regular BAS call
' ; into a call that can go into a COM object procedure. It is assumed that
' ; all arguments are either ByRef or 4-byte ByVal parameters. It is
' ; further assumed that it's a Function that returns a Long. This should
' ; cover the vast majority of API callbacks as well as subclassing.
' ;
' ; This thunk can handle one, two, three, or four incoming arguments.
' ; As an example, we'll assume two incoming arguments. In a BAS module,
' ; such a function would look like the following:
' ;
' ; Function OurCallBack(ByRef Arg1 As Long, ByRef Arg2 As Long) As Long
' ;
' ; When in a COM object, under the hood, this would be transformed as follows:
' ;
' ; Function OurCallBack(ByVal OurObjPtr As Long, ByRef Arg1 As Long, _
' ; ByRef Arg2 As Long, ByRef FnRet As Long) As HRESULT
' ;
' ; So, to treat it as a BAS module call, we've got to add the OurObjPtr and
' ; deal with the return as an argument. We just discard the HRESULT return.
' ;
bb(0) = &H55 ' push ebp ; Save base pointer, always done.
bb(1) = &H89: bb(2) = &HE5 ' mov ebp, esp ; Save stack pointer in ebp.
bb(3) = &H83: bb(4) = &HEC: bb(5) = &H4 ' sub esp, 4 ; Allocate 4 bytes of storage for local variables.
' ;
' ; We now start setting up for the COM procedure call.
' ;
bb(6) = &H89: bb(7) = &HE8 ' mov eax, ebp ; Base pointer into eax.
bb(8) = &H83: bb(9) = &HE8: bb(10) = &H4 ' sub eax, 4 ; Address for COM proc's FnRet to return.
bb(11) = &H50 ' push eax ; and pushed on the stack for ByRef return.
bb(12) = &HFF: bb(13) = &H75: bb(14) = &H14 ' push [ebp + 20] ; Arg4 onto stack. Possibly patch with NOP.
bb(15) = &HFF: bb(16) = &H75: bb(17) = &H10 ' push [ebp + 16] ; Arg3 onto stack. Possibly patch with NOP.
bb(18) = &HFF: bb(19) = &H75: bb(20) = &HC ' push [ebp + 12] ; Arg2 onto stack. Possibly patch with NOP.
bb(21) = &HFF: bb(22) = &H75: bb(23) = &H8 ' push [ebp + 8] ; Arg1 onto stack. At least one arg is required.
bb(24) = &H68: bb(25) = &H55: bb(26) = &H55: bb(27) = &H55: bb(28) = &H55 ' push 0x55555555 ; We'll patch this up with the OurObjPtr address.
' ;
bb(29) = &HB8: bb(30) = &H66: bb(31) = &H66: bb(32) = &H66: bb(33) = &H66 ' mov eax, 0x66666666 ; We'll patch this up with the address to the COM procedure.
bb(34) = &HFF: bb(35) = &HD0 ' call eax ; Call the COM procedure.
' ;
' ; We're back, so patch up the return from COM proc, and return.
' ; The stack will take care of itself, as ByVal are discarded,
' ; and ByRef were passed through with the same address.
' ;
bb(36) = &H8B: bb(37) = &H45: bb(38) = &HFC ' mov eax, [ebp - 4] ; Return the last argument's value as our return.
bb(39) = &H89: bb(40) = &HEC ' mov esp, ebp ; Restore stack pointer from base pointer.
bb(41) = &H5D ' pop ebp ; Restore base pointer.
bb(42) = &HC2: bb(43) = &H8: bb(44) = &H0 ' ret 8 ; Reset stack (for passed args) and return. Patch up 8 for exact number of args (x 4).
'
' We will need the size.
iThunkSize = UBound(bb) - LBound(bb) + 1&
'
' If not four arguments, blank out unused.
If ComProcArgCount < 4& Then bb(12) = &H90: bb(13) = &H90: bb(14) = &H90 ' &H90 = NOP (no operation)
If ComProcArgCount < 3& Then bb(15) = &H90: bb(16) = &H90: bb(17) = &H90
If ComProcArgCount < 2& Then bb(18) = &H90: bb(19) = &H90: bb(20) = &H90
' At least one argument is required, so bb(21) thru bb(23) don't change.
'
' Patch up our two supplied addresses.
CopyMemory bb(25), ObjPtr(o), 4& ' The ObjPtr() that's needed as an argument.
CopyMemory bb(30), ComProcAddress, 4& ' Where the actual call to the COM procedure is being made.
'
' Patch up the return for how much of the stack to reset.
bb(43) = ComProcArgCount * 4&
'
' Get some executable memory. Make sure we release it when we're done.
Const MEM_COMMIT As Long = &H1000&
Const PAGE_EXECUTE_READWRITE As Long = &H40&
AddressOfThunkForComProc = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'
' Move thunk into executable memory, and return our virtual memory's address.
CopyMemory ByVal AddressOfThunkForComProc, bb(0), iThunkSize
End Function
The actual assembly code is shown far out to the right of the machine code being put into the Byte array. This is actually not terribly difficult to follow. When actually returning, the actual HRESULT return is discarded (as it is when we call any procedure in a COM object), and replaced with that last Long argument that was added.
Again, so basically, what we have is a piece of machine code that turns a BAS call into a COM call ... and then, upon return, it discards HRESULT and makes it look like a typical BAS function return.
One last piece ... when we made our thunk, we allocated some memory which allows executable code. When we're done, we should deallocate this memory:
Code:
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Public Sub FreeTheThunk(ByVal pVirtualMem As Long, ByVal iThunkSize As Long)
Const MEM_RELEASE As Long = &H8000&
VirtualFree pVirtualMem, iThunkSize, MEM_RELEASE
End Sub
If we don't do this last piece, we'll have a bit of a memory leak. However, those do clear up when an application exits.
And voilà, we've got all the pieces for using a COM object's procedure as an API CallBack.
Here is everything we've discussed so far in a BAS module: Attachment 186066 (CallingVb6Objects.BAS)
-
Re: API CallBacks Using an Object's Procedure
Example #1:
Just to illustrate that it can work, I'll setup to run an API timer, using only that code in the CallingVb6Objects.bas file (attached in post above), and a CallBack procedure in a Form1:
Code:
Option Explicit
'
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
'
Dim TimerID As Long ' Save this so we can kill the timer.
'
Dim ThunkSize As Long ' \
Dim pVirtualMem As Long ' Save these two so we can release the thunk memory.
'
Private Sub Form_Load()
Me.AutoRedraw = True
Me.Font.Name = "Segoe UI Semibold"
Me.Font.Size = 12
End Sub
Private Sub Form_Initialize()
' Get our procedure address and argument count.
Dim iArgCount As Long
Dim pProcAddress As Long
pProcAddress = Vb6ComCodeObjectAddressOf(Me, "TimerCallBackProc", iArgCount)
' Make THUNK into executable memory.
pVirtualMem = AddressOfThunkForComProc(Me, pProcAddress, iArgCount, ThunkSize)
' Create an API timer with our thunk.
' Callsback every 5000 milliseconds (5 seconds).
TimerID = SetTimer(0&, 0&, 5000&, pVirtualMem)
End Sub
Public Function TimerCallBackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
Me.Print "Time is: "; Format$(Time, "hh:nn:ss AM/PM")
End Function
Private Sub Form_Terminate()
KillTimer 0&, TimerID ' Kill our API timer.
FreeTheThunk pVirtualMem, ThunkSize ' Give our thunk memory back.
End Sub
Let's look at the individual procedures in this example:
Form_Load: All I'm doing here is setting up the form a bit.
Form_Initialize: Here's where I'm setting up to use the TimerCallBackProc procedure as a CallBack. Notice that it's the pVirtualMem thunk address that's passed to the SetTimer API, so that the BAS-like CallBack from Windows can be rearranged for the COM procedure.
TimerCallBackProc: This is the CallBack that Windows calls every 5 seconds.
Form_Terminate: This is just cleanup: 1) kill the timer, 2) release our thunk memory.
Example #2:
Part of the fascination with all of this is the ability to keep everything wrapped into a single object. Therefore, in this next example, I've just copied all the code from the CallingVb6Objects.bas module, and pasted it into the Form1's code. I also made all the support procedures Private.
So, here's code for a Form1, with no other code needed, that performs a Timer API CallBack:
Code:
Option Explicit
'
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function vbaCheckType Lib "msvbvm60" Alias "__vbaCheckType" (ByVal pObj As Any, ByRef pIID As Any) As Boolean
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByRef lpString As Any) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByRef psz As Any, ByVal lSize As Long) As String
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
'
Dim TimerID As Long ' Save this so we can kill the timer.
'
Dim ThunkSize As Long ' \
Dim pVirtualMem As Long ' Save these two so we can release the thunk memory.
'
Private Sub Form_Load()
Me.AutoRedraw = True
Me.Font.Name = "Segoe UI Semibold"
Me.Font.Size = 12
End Sub
Private Sub Form_Initialize()
' Get our procedure address and argument count.
Dim iArgCount As Long
Dim pProcAddress As Long
pProcAddress = Vb6ComCodeObjectAddressOf(Me, "TimerCallBackProc", iArgCount)
' Make THUNK into executable memory.
pVirtualMem = AddressOfThunkForComProc(Me, pProcAddress, iArgCount, ThunkSize)
' Create an API timer with our thunk.
' Callsback every 5000 milliseconds (5 seconds).
TimerID = SetTimer(0&, 0&, 5000&, pVirtualMem)
End Sub
Public Function TimerCallBackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
Me.Print "Time is: "; Format$(Time, "hh:nn:ss AM/PM")
End Function
Private Sub Form_Terminate()
KillTimer 0&, TimerID ' Kill our API timer.
FreeTheThunk pVirtualMem, ThunkSize ' Give our thunk memory back.
End Sub
' *************************************************
' API CallBack to object ... support procedures.
' *************************************************
Private Function Vb6ComCodeObjectAddressOf(ByVal o As Object, ByVal sMethodName As String, Optional ByRef lArgCount As Long) As Long
' lArgCount is an optional RETURN. ByRef/ByVal doesn't matter, and TYPE doesn't matter. If it's a Function the return isn't counted.
' The caller is responsible for knowing how to use the returned address, or crash may result.
' See more notes within VtableOffsetForVb6ComMethod procedure.
'
' Returns ZERO if not found, or it's not a PUBLIC method.
'
lArgCount = 0& ' Zero out anything there to start.
Dim iVoffset As Long: iVoffset = VtableOffsetForVb6ComMethod(o, sMethodName, lArgCount)
If iVoffset = 0& Then Exit Function ' This checks to make sure the object is okay.
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable ' Get pointer to start of vTable.
pVtable = pVtable + iVoffset ' Address to our method in the vTable.
GetMem4 ByVal pVtable, Vb6ComCodeObjectAddressOf ' Pointer into actual code (the method).
End Function
Private Function VtableOffsetForVb6ComMethod(ByVal o As Object, ByVal sMethodName As String, Optional ByRef lArgCount As Long) As Long
' Searches PUBLIC methods. It "could" find Private & Friend, but only in the IDE, not compiled.
' Does NOT search properties (i.e., Public variables or Get/Let/Set procedures).
' Returns an OFFSET address ready to be added to the vTable address.
' Optional bbArgCount return is a count of passed in arguments.
' ByRef/ByVal doesn't matter, and TYPE doesn't matter.
' If it's a Function the return isn't counted.
'
' If it can't be found, ZERO is returned.
'
If Not ObjectIsVb6ComCodeModule(o) Then Exit Function ' Make sure we're dealing with a VB6 COM-code object.
sMethodName = UCase$(sMethodName)
'
Dim pVTbl As Long: GetMem4 ByVal ObjPtr(o), pVTbl ' Pointer to vTable.
Dim pObjInfo As Long: GetMem4 ByVal pVTbl - 4&, pObjInfo ' Pointer to tObjectInfo structure.
Dim pPubDesc As Long: GetMem4 ByVal pObjInfo + &H18&, pPubDesc ' tObjectInfo.aObject which points to tObject structure.
Dim pPrivDesc As Long: GetMem4 ByVal pObjInfo + &HC&, pPrivDesc ' tObjectInfo.lpPrivateObject which points to tPrivateObj structure.
'
If pPrivDesc = 0& Then Exit Function ' Just a double-check.
'
Dim lIndex As Long
Dim pName As Long
'
' Search the procedures within the module.
Dim pMethDesc As Long
Dim iMethOffset As Integer
Dim bbArgs As Byte
Dim lMethodsCnt As Long: GetMem2 ByVal pPubDesc + &H1C&, lMethodsCnt ' tObject.ProcCount value.
Dim pNames As Long: GetMem4 ByVal pPubDesc + &H20&, pNames ' tObject.aProcNamesArray which points to an array of name pointers.
Dim pMethodsPtr As Long: GetMem4 ByVal pPrivDesc + &H18&, pMethodsPtr ' tPrivateObj.lpFuncTypeInfo which points to an array of pointers.
'
' Loop through methods and see if we can find the one we want.
For lIndex = 0& To lMethodsCnt - 1&
GetMem4 ByVal pMethodsPtr + lIndex * 4&, pMethDesc ' From the array, getting a pointer to a method structure (tMethInfo).
If pMethDesc Then ' Not sure if this ever returns zero, maybe for "Private" methods?
GetMem2 ByVal pMethDesc + 2&, iMethOffset ' Out of tMethInfo structure.
GetMem1 ByVal pMethDesc, bbArgs ' First two bits of bbArgs are: set=3, get=1, let=2, method=0 (Sub or Fn).
If (bbArgs And CByte(3)) = CByte(0) Then ' Make sure it's a method.
If iMethOffset And 1 Then ' First bit, 1=Public.
GetMem4 ByVal pNames + lIndex * 4&, pName ' Dig pointer to method name from array of name pointers.
If sMethodName = UCase$(SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))) Then
VtableOffsetForVb6ComMethod = CLng(iMethOffset And &HFFFC) ' First two bits are something else (first is Public=1,Private=0).
Dim bbFlags As Byte: GetMem1 ByVal pMethDesc + 1&, bbFlags ' Both bbArgs & bbFlags out of tMethInfo structure.
bbFlags = bbFlags And CByte(1) ' 0 (no return), 1 (return).
lArgCount = CLng(bbArgs \ CByte(4) - bbFlags) ' Calculate arguments, excluding any return argument. Tested for vbGet, vbLet, vbSet, vbMethod (both Function & Sub).
Exit Function
End If
End If
End If
End If
Next
'
' Return zero if not found.
End Function
Private Sub FreeTheThunk(ByVal pVirtualMem As Long, ByVal iThunkSize As Long)
Const MEM_RELEASE As Long = &H8000&
VirtualFree pVirtualMem, iThunkSize, MEM_RELEASE
End Sub
Private Function AddressOfThunkForComProc(ByVal o As Object, _
ByVal ComProcAddress As Long, _
ByVal ComProcArgCount As Long, _
ByRef iThunkSize As Long) As Long
' This makes a thunk and places it into a Byte array.
' This thunk is specifically for allowing COM procedures to be called as standard BAS procedures.
'
' ComProcAddress: The actual address of the COM procedure, typically dug out of the vTable.
'
' ComObjPtr: Usually comes out of ObjPtr(TheObject) for an instantiated VB6 COM/Code object (Form, Class, UC, PropertyPage, or DataReport).
'
' ComProcArgCount: The number of arguments "seen" in the code of the COM procedure.
' It's MANDATORY that this be a number from 1 to 4 !!!!
' It is assumed all the arguments are either ByRef or 4-byte ByVal arguments.
' Anything else will fail and probably cause a crash.
'
' iThunkSize: Returned, and it must be used with VirtualFree to free this thunk memory.
' The FreeTheThunk procedure is setup for this.
'
If ComProcAddress = 0& Or ObjPtr(o) = 0& Then Exit Function
If ComProcArgCount < 1& Or ComProcArgCount > 4& Then Exit Function
Dim bb() As Byte
'
' Auto generated by Elroy's thunk maker.
ReDim bb(44)
' ;
' ; The idea here is to convert a call that thinks it's a regular BAS call
' ; into a call that can go into a COM object procedure. It is assumed that
' ; all arguments are either ByRef or 4-byte ByVal parameters. It is
' ; further assumed that it's a Function that returns a Long. This should
' ; cover the vast majority of API callbacks as well as subclassing.
' ;
' ; This thunk can handle one, two, three, or four incoming arguments.
' ; As an example, we'll assume two incoming arguments. In a BAS module,
' ; such a function would look like the following:
' ;
' ; Function OurCallBack(ByRef Arg1 As Long, ByRef Arg2 As Long) As Long
' ;
' ; When in a COM object, under the hood, this would be transformed as follows:
' ;
' ; Function OurCallBack(ByVal OurObjPtr As Long, ByRef Arg1 As Long, _
' ; ByRef Arg2 As Long, ByRef FnRet As Long) As HRESULT
' ;
' ; So, to treat it as a BAS module call, we've got to add the OurObjPtr and
' ; deal with the return as an argument. We just discard the HRESULT return.
' ;
bb(0) = &H55 ' push ebp ; Save base pointer, always done.
bb(1) = &H89: bb(2) = &HE5 ' mov ebp, esp ; Save stack pointer in ebp.
bb(3) = &H83: bb(4) = &HEC: bb(5) = &H4 ' sub esp, 4 ; Allocate 4 bytes of storage for local variables.
' ;
' ; We now start setting up for the COM procedure call.
' ;
bb(6) = &H89: bb(7) = &HE8 ' mov eax, ebp ; Base pointer into eax.
bb(8) = &H83: bb(9) = &HE8: bb(10) = &H4 ' sub eax, 4 ; Address for COM proc's FnRet to return.
bb(11) = &H50 ' push eax ; and pushed on the stack for ByRef return.
bb(12) = &HFF: bb(13) = &H75: bb(14) = &H14 ' push [ebp + 20] ; Arg4 onto stack. Possibly patch with NOP.
bb(15) = &HFF: bb(16) = &H75: bb(17) = &H10 ' push [ebp + 16] ; Arg3 onto stack. Possibly patch with NOP.
bb(18) = &HFF: bb(19) = &H75: bb(20) = &HC ' push [ebp + 12] ; Arg2 onto stack. Possibly patch with NOP.
bb(21) = &HFF: bb(22) = &H75: bb(23) = &H8 ' push [ebp + 8] ; Arg1 onto stack. At least one arg is required.
bb(24) = &H68: bb(25) = &H55: bb(26) = &H55: bb(27) = &H55: bb(28) = &H55 ' push 0x55555555 ; We'll patch this up with the OurObjPtr address.
' ;
bb(29) = &HB8: bb(30) = &H66: bb(31) = &H66: bb(32) = &H66: bb(33) = &H66 ' mov eax, 0x66666666 ; We'll patch this up with the address to the COM procedure.
bb(34) = &HFF: bb(35) = &HD0 ' call eax ; Call the COM procedure.
' ;
' ; We're back, so patch up the return from COM proc, and return.
' ; The stack will take care of itself, as ByVal are discarded,
' ; and ByRef were passed through with the same address.
' ;
bb(36) = &H8B: bb(37) = &H45: bb(38) = &HFC ' mov eax, [ebp - 4] ; Return the last argument's value as our return.
bb(39) = &H89: bb(40) = &HEC ' mov esp, ebp ; Restore stack pointer from base pointer.
bb(41) = &H5D ' pop ebp ; Restore base pointer.
bb(42) = &HC2: bb(43) = &H8: bb(44) = &H0 ' ret 8 ; Reset stack (for passed args) and return. Patch up 8 for exact number of args (x 4).
'
' We will need the size.
iThunkSize = UBound(bb) - LBound(bb) + 1&
'
' If not four arguments, blank out unused.
If ComProcArgCount < 4& Then bb(12) = &H90: bb(13) = &H90: bb(14) = &H90 ' &H90 = NOP (no operation)
If ComProcArgCount < 3& Then bb(15) = &H90: bb(16) = &H90: bb(17) = &H90
If ComProcArgCount < 2& Then bb(18) = &H90: bb(19) = &H90: bb(20) = &H90
' At least one argument is required, so bb(21) thru bb(23) don't change.
'
' Patch up our two supplied addresses.
CopyMemory bb(25), ObjPtr(o), 4& ' The ObjPtr() that's needed as an argument.
CopyMemory bb(30), ComProcAddress, 4& ' Where the actual call to the COM procedure is being made.
'
' Patch up the return for how much of the stack to reset.
bb(43) = ComProcArgCount * 4&
'
' Get some executable memory. Make sure we release it when we're done.
Const MEM_COMMIT As Long = &H1000&
Const PAGE_EXECUTE_READWRITE As Long = &H40&
AddressOfThunkForComProc = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'
' Move thunk into executable memory, and return our virtual memory's address.
CopyMemory ByVal AddressOfThunkForComProc, bb(0), iThunkSize
End Function
Private Function ObjectIsVb6ComCodeModule(ByRef o As IUnknown) As Boolean
' If it's an instantiated Class, Form, UC, PropPage, DataReport, returns TRUE, else FALSE.
If ObjPtr(o) = 0& Then Exit Function ' Make sure "something" is instantiated.
Dim aGUID(1&) As Currency ' Just to get 16 easily accessible bytes.
aGUID(0&) = 128347367577987.1845@ ' Const AreYouABasicInstance As String = "{0B6C9465-D082-11CF-8B4F-00A0C90F2704}"
aGUID(1&) = 29922525889064.5387@ ' turned into two numbers stuffed into our Currency array.
ObjectIsVb6ComCodeModule = vbaCheckType(o, aGUID(0)) ' Check and see if we are this "TYPE" (Class, Form, UC, PropPage, or DataRep).
End Function
-
1 Attachment(s)
Re: API CallBacks Using an Object's Procedure
Example #3:
And, for grins, I'll do it to list our monitor handles and then to find the primary monitor's handle. I'll use two separate CallBacks in this one, but I'll still keep it all in a single module (Form1). And here it is:
Code:
Option Explicit
'
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function vbaCheckType Lib "msvbvm60" Alias "__vbaCheckType" (ByVal pObj As Any, ByRef pIID As Any) As Boolean
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByRef lpString As Any) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByRef psz As Any, ByVal lSize As Long) As String
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hDC As Long, lprcClip As Any, ByVal lpfnEnum As Long, dwData As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As Any) As Long
'
Public Function MonitorHandleEnumCallback(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As Variant, dwData As Long) As Long
' uRect is a Variant because it's not used and it's 16 bytes.
dwData = dwData + 1& ' The actual count.
Me.Print " "; CStr(hMonitor)
MonitorHandleEnumCallback = 1& ' Count them all.
End Function
Public Function PrimaryMonitorHandleEnumCallback(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As Variant, dwData As Long) As Long
' uRect is a Variant because it's not used and it's 16 bytes.
Dim MonInfo(9&) As Long ' cbSize As Long, rcMonitor As RECT, rcWork As RECT, dwFlags As Long
MonInfo(0&) = 40&
GetMonitorInfo hMonitor, MonInfo(0&)
If MonInfo(9&) = &H1& Then
dwData = hMonitor
PrimaryMonitorHandleEnumCallback = 0& ' Found it.
Else
PrimaryMonitorHandleEnumCallback = 1& ' Keep looking.
End If
End Function
Private Sub Form_Load()
' Form setup.
Me.AutoRedraw = True
Me.Font.Name = "Segoe UI Semibold"
Me.Font.Size = 12
' Some variables we'll use.
Dim ThunkSize As Long
Dim pVirtualMem As Long
Dim iArgCount As Long
Dim pProcAddress As Long
' First, just list our monitors.
' Get our procedure address and argument count.
pProcAddress = Vb6ComCodeObjectAddressOf(Me, "MonitorHandleEnumCallback", iArgCount)
' Make THUNK into executable memory.
pVirtualMem = AddressOfThunkForComProc(Me, pProcAddress, iArgCount, ThunkSize)
' Count our monitors ... their handles are listed in the callback.
Me.Print "Monitor handle(s):"
Dim iMonitorCount As Long
EnumDisplayMonitors 0&, ByVal 0&, pVirtualMem, iMonitorCount
Me.Print "Total monitor count: "; CStr(iMonitorCount)
' Give our thunk memory back.
FreeTheThunk pVirtualMem, ThunkSize
' Now let's use a callback to find our primary monitor.
' Get our procedure address and argument count.
pProcAddress = Vb6ComCodeObjectAddressOf(Me, "PrimaryMonitorHandleEnumCallback", iArgCount)
' Make THUNK into executable memory.
pVirtualMem = AddressOfThunkForComProc(Me, pProcAddress, iArgCount, ThunkSize)
' Get primary monitor handle using callback.
Dim hPrimaryMonitor As Long
EnumDisplayMonitors 0&, ByVal 0&, pVirtualMem, hPrimaryMonitor
Me.Print "Handle of primary monitor: "; CStr(hPrimaryMonitor)
' Give our thunk memory back.
FreeTheThunk pVirtualMem, ThunkSize
End Sub
' *************************************************
' API CallBack to object ... support procedures.
' *************************************************
Private Function Vb6ComCodeObjectAddressOf(ByVal o As Object, ByVal sMethodName As String, Optional ByRef lArgCount As Long) As Long
' lArgCount is an optional RETURN. ByRef/ByVal doesn't matter, and TYPE doesn't matter. If it's a Function the return isn't counted.
' The caller is responsible for knowing how to use the returned address, or crash may result.
' See more notes within VtableOffsetForVb6ComMethod procedure.
'
' Returns ZERO if not found, or it's not a PUBLIC method.
'
lArgCount = 0& ' Zero out anything there to start.
Dim iVoffset As Long: iVoffset = VtableOffsetForVb6ComMethod(o, sMethodName, lArgCount)
If iVoffset = 0& Then Exit Function ' This checks to make sure the object is okay.
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable ' Get pointer to start of vTable.
pVtable = pVtable + iVoffset ' Address to our method in the vTable.
GetMem4 ByVal pVtable, Vb6ComCodeObjectAddressOf ' Pointer into actual code (the method).
End Function
Private Function VtableOffsetForVb6ComMethod(ByVal o As Object, ByVal sMethodName As String, Optional ByRef lArgCount As Long) As Long
' Searches PUBLIC methods. It "could" find Private & Friend, but only in the IDE, not compiled.
' Does NOT search properties (i.e., Public variables or Get/Let/Set procedures).
' Returns an OFFSET address ready to be added to the vTable address.
' Optional bbArgCount return is a count of passed in arguments.
' ByRef/ByVal doesn't matter, and TYPE doesn't matter.
' If it's a Function the return isn't counted.
'
' If it can't be found, ZERO is returned.
'
If Not ObjectIsVb6ComCodeModule(o) Then Exit Function ' Make sure we're dealing with a VB6 COM-code object.
sMethodName = UCase$(sMethodName)
'
Dim pVTbl As Long: GetMem4 ByVal ObjPtr(o), pVTbl ' Pointer to vTable.
Dim pObjInfo As Long: GetMem4 ByVal pVTbl - 4&, pObjInfo ' Pointer to tObjectInfo structure.
Dim pPubDesc As Long: GetMem4 ByVal pObjInfo + &H18&, pPubDesc ' tObjectInfo.aObject which points to tObject structure.
Dim pPrivDesc As Long: GetMem4 ByVal pObjInfo + &HC&, pPrivDesc ' tObjectInfo.lpPrivateObject which points to tPrivateObj structure.
'
If pPrivDesc = 0& Then Exit Function ' Just a double-check.
'
Dim lIndex As Long
Dim pName As Long
'
' Search the procedures within the module.
Dim pMethDesc As Long
Dim iMethOffset As Integer
Dim bbArgs As Byte
Dim lMethodsCnt As Long: GetMem2 ByVal pPubDesc + &H1C&, lMethodsCnt ' tObject.ProcCount value.
Dim pNames As Long: GetMem4 ByVal pPubDesc + &H20&, pNames ' tObject.aProcNamesArray which points to an array of name pointers.
Dim pMethodsPtr As Long: GetMem4 ByVal pPrivDesc + &H18&, pMethodsPtr ' tPrivateObj.lpFuncTypeInfo which points to an array of pointers.
'
' Loop through methods and see if we can find the one we want.
For lIndex = 0& To lMethodsCnt - 1&
GetMem4 ByVal pMethodsPtr + lIndex * 4&, pMethDesc ' From the array, getting a pointer to a method structure (tMethInfo).
If pMethDesc Then ' Not sure if this ever returns zero, maybe for "Private" methods?
GetMem2 ByVal pMethDesc + 2&, iMethOffset ' Out of tMethInfo structure.
GetMem1 ByVal pMethDesc, bbArgs ' First two bits of bbArgs are: set=3, get=1, let=2, method=0 (Sub or Fn).
If (bbArgs And CByte(3)) = CByte(0) Then ' Make sure it's a method.
If iMethOffset And 1 Then ' First bit, 1=Public.
GetMem4 ByVal pNames + lIndex * 4&, pName ' Dig pointer to method name from array of name pointers.
If sMethodName = UCase$(SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))) Then
VtableOffsetForVb6ComMethod = CLng(iMethOffset And &HFFFC) ' First two bits are something else (first is Public=1,Private=0).
Dim bbFlags As Byte: GetMem1 ByVal pMethDesc + 1&, bbFlags ' Both bbArgs & bbFlags out of tMethInfo structure.
bbFlags = bbFlags And CByte(1) ' 0 (no return), 1 (return).
lArgCount = CLng(bbArgs \ CByte(4) - bbFlags) ' Calculate arguments, excluding any return argument. Tested for vbGet, vbLet, vbSet, vbMethod (both Function & Sub).
Exit Function
End If
End If
End If
End If
Next
'
' Return zero if not found.
End Function
Private Sub FreeTheThunk(ByVal pVirtualMem As Long, ByVal iThunkSize As Long)
Const MEM_RELEASE As Long = &H8000&
VirtualFree pVirtualMem, iThunkSize, MEM_RELEASE
End Sub
Private Function AddressOfThunkForComProc(ByVal o As Object, _
ByVal ComProcAddress As Long, _
ByVal ComProcArgCount As Long, _
ByRef iThunkSize As Long) As Long
' This makes a thunk and places it into a Byte array.
' This thunk is specifically for allowing COM procedures to be called as standard BAS procedures.
'
' ComProcAddress: The actual address of the COM procedure, typically dug out of the vTable.
'
' ComObjPtr: Usually comes out of ObjPtr(TheObject) for an instantiated VB6 COM/Code object (Form, Class, UC, PropertyPage, or DataReport).
'
' ComProcArgCount: The number of arguments "seen" in the code of the COM procedure.
' It's MANDATORY that this be a number from 1 to 4 !!!!
' It is assumed all the arguments are either ByRef or 4-byte ByVal arguments.
' Anything else will fail and probably cause a crash.
'
' iThunkSize: Returned, and it must be used with VirtualFree to free this thunk memory.
' The FreeTheThunk procedure is setup for this.
'
If ComProcAddress = 0& Or ObjPtr(o) = 0& Then Exit Function
If ComProcArgCount < 1& Or ComProcArgCount > 4& Then Exit Function
Dim bb() As Byte
'
' Auto generated by Elroy's thunk maker.
ReDim bb(44)
' ;
' ; The idea here is to convert a call that thinks it's a regular BAS call
' ; into a call that can go into a COM object procedure. It is assumed that
' ; all arguments are either ByRef or 4-byte ByVal parameters. It is
' ; further assumed that it's a Function that returns a Long. This should
' ; cover the vast majority of API callbacks as well as subclassing.
' ;
' ; This thunk can handle one, two, three, or four incoming arguments.
' ; As an example, we'll assume two incoming arguments. In a BAS module,
' ; such a function would look like the following:
' ;
' ; Function OurCallBack(ByRef Arg1 As Long, ByRef Arg2 As Long) As Long
' ;
' ; When in a COM object, under the hood, this would be transformed as follows:
' ;
' ; Function OurCallBack(ByVal OurObjPtr As Long, ByRef Arg1 As Long, _
' ; ByRef Arg2 As Long, ByRef FnRet As Long) As HRESULT
' ;
' ; So, to treat it as a BAS module call, we've got to add the OurObjPtr and
' ; deal with the return as an argument. We just discard the HRESULT return.
' ;
bb(0) = &H55 ' push ebp ; Save base pointer, always done.
bb(1) = &H89: bb(2) = &HE5 ' mov ebp, esp ; Save stack pointer in ebp.
bb(3) = &H83: bb(4) = &HEC: bb(5) = &H4 ' sub esp, 4 ; Allocate 4 bytes of storage for local variables.
' ;
' ; We now start setting up for the COM procedure call.
' ;
bb(6) = &H89: bb(7) = &HE8 ' mov eax, ebp ; Base pointer into eax.
bb(8) = &H83: bb(9) = &HE8: bb(10) = &H4 ' sub eax, 4 ; Address for COM proc's FnRet to return.
bb(11) = &H50 ' push eax ; and pushed on the stack for ByRef return.
bb(12) = &HFF: bb(13) = &H75: bb(14) = &H14 ' push [ebp + 20] ; Arg4 onto stack. Possibly patch with NOP.
bb(15) = &HFF: bb(16) = &H75: bb(17) = &H10 ' push [ebp + 16] ; Arg3 onto stack. Possibly patch with NOP.
bb(18) = &HFF: bb(19) = &H75: bb(20) = &HC ' push [ebp + 12] ; Arg2 onto stack. Possibly patch with NOP.
bb(21) = &HFF: bb(22) = &H75: bb(23) = &H8 ' push [ebp + 8] ; Arg1 onto stack. At least one arg is required.
bb(24) = &H68: bb(25) = &H55: bb(26) = &H55: bb(27) = &H55: bb(28) = &H55 ' push 0x55555555 ; We'll patch this up with the OurObjPtr address.
' ;
bb(29) = &HB8: bb(30) = &H66: bb(31) = &H66: bb(32) = &H66: bb(33) = &H66 ' mov eax, 0x66666666 ; We'll patch this up with the address to the COM procedure.
bb(34) = &HFF: bb(35) = &HD0 ' call eax ; Call the COM procedure.
' ;
' ; We're back, so patch up the return from COM proc, and return.
' ; The stack will take care of itself, as ByVal are discarded,
' ; and ByRef were passed through with the same address.
' ;
bb(36) = &H8B: bb(37) = &H45: bb(38) = &HFC ' mov eax, [ebp - 4] ; Return the last argument's value as our return.
bb(39) = &H89: bb(40) = &HEC ' mov esp, ebp ; Restore stack pointer from base pointer.
bb(41) = &H5D ' pop ebp ; Restore base pointer.
bb(42) = &HC2: bb(43) = &H8: bb(44) = &H0 ' ret 8 ; Reset stack (for passed args) and return. Patch up 8 for exact number of args (x 4).
'
' We will need the size.
iThunkSize = UBound(bb) - LBound(bb) + 1&
'
' If not four arguments, blank out unused.
If ComProcArgCount < 4& Then bb(12) = &H90: bb(13) = &H90: bb(14) = &H90 ' &H90 = NOP (no operation)
If ComProcArgCount < 3& Then bb(15) = &H90: bb(16) = &H90: bb(17) = &H90
If ComProcArgCount < 2& Then bb(18) = &H90: bb(19) = &H90: bb(20) = &H90
' At least one argument is required, so bb(21) thru bb(23) don't change.
'
' Patch up our two supplied addresses.
CopyMemory bb(25), ObjPtr(o), 4& ' The ObjPtr() that's needed as an argument.
CopyMemory bb(30), ComProcAddress, 4& ' Where the actual call to the COM procedure is being made.
'
' Patch up the return for how much of the stack to reset.
bb(43) = ComProcArgCount * 4&
'
' Get some executable memory. Make sure we release it when we're done.
Const MEM_COMMIT As Long = &H1000&
Const PAGE_EXECUTE_READWRITE As Long = &H40&
AddressOfThunkForComProc = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'
' Move thunk into executable memory, and return our virtual memory's address.
CopyMemory ByVal AddressOfThunkForComProc, bb(0&), iThunkSize
End Function
Private Function ObjectIsVb6ComCodeModule(ByRef o As IUnknown) As Boolean
' If it's an instantiated Class, Form, UC, PropPage, DataReport, returns TRUE, else FALSE.
If ObjPtr(o) = 0& Then Exit Function ' Make sure "something" is instantiated.
Dim aGUID(1&) As Currency ' Just to get 16 easily accessible bytes.
aGUID(0&) = 128347367577987.1845@ ' Const AreYouABasicInstance As String = "{0B6C9465-D082-11CF-8B4F-00A0C90F2704}"
aGUID(1&) = 29922525889064.5387@ ' turned into two numbers stuffed into our Currency array.
ObjectIsVb6ComCodeModule = vbaCheckType(o, aGUID(0&)) ' Check and see if we are this "TYPE" (Class, Form, UC, PropPage, or DataRep).
End Function
This time, both CallBacks were "one-shot" callbacks, so I created and deleted the thunks all in the same section of code. When it runs, here's the output:
Attachment 186077
--------------------------
Ok, what if we'd like to keep our CallBack procedures Private? You can do this when they're in a BAS module, even with subclassing. And doing this provides some advantages:
- Being able to declare Private UDTs in the module and have them used in the CallBack arguments.
- Making sure no other code outside the module calls the CallBack module.
However, we stated above that the VtableOffsetForVb6ComMethod procedure only finds Public procedures within our object's code. So, we have to resort to other means, and to do this, we need to return to ideas surrounding the vTable.
Challenge #4: How many entries, and what categories of entries, are in the vTable? We will need this information to proceed with making a Private CallBack procedure within a COM object.
(As a note, Paul Caton, LaVolpe, and others have used "magic numbers" to figure this out. However, I was never fond of these "magic numbers". The following approach goes back into the structures associated with each COM object and digs out the information.)
Code:
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Public Function Vb6ComCodeObjectVtableEntries(o As Object, Optional iInterfaceCount As Long, Optional iIntrinsicCount As Long, Optional iCoderCodedCount As Long) As Long
' Return is the TOTAL, with Optional arguments returned as individual pieces.
'
If Not ObjectIsVb6ComCodeModule(o) Then Exit Function
'
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable
Dim ptObjectInfo As Long: GetMem4 ByVal pVtable - 4&, ptObjectInfo
iInterfaceCount = 7& ' IUnknown and IDispatch.
GetMem2 ByVal ptObjectInfo + &H62&, iIntrinsicCount ' Out of the tObjectInfo structure (wPCodeCount).
GetMem2 ByVal ptObjectInfo + &H60&, iCoderCodedCount ' Out of the tObjectInfo structure (wMethodLinkCount).
Vb6ComCodeObjectVtableEntries = iInterfaceCount + iIntrinsicCount + iCoderCodedCount
End Function
Notice that we're still dependent upon it being either a Form, Class, UserControl, PropPage, or DataReport, by checking with ObjectIsVb6ComCodeModule.
This ObjectIsVb6ComCodeModule function returns the total of the vTable entries. However, more important to us are the numbers in each category, the optional iInterfaceCount, iIntrinsicCount, and iCoderCodedCount. Above, it was stated that we're not concerned about the interface entries nor the intrinsic entries ... and we're still not. However, we do need to know their counts, and we've now got them.
But we do need to focus on the iCoderCodedCount, and we need to learn how to actually count them. This count is all of our Public variables, Public procedures, and Private/Friend procedures that we've coded up in our COM code module, and they appear in the vTable in that order. Private variables (even at the module level) do not appear in the vTable.
-
1 Attachment(s)
Re: API CallBacks Using an Object's Procedure
Challenge #5: Learning how to count vTable entries we've created from our coding. (I mostly followed LaVolpe's lead on this one.)
Public variables are actually compiled as a Property Get and Property Let (or Property Set for Public object variables). For these, the Get always appears first. So, Public variables actually have two vTable entries.
After those, the Public procedures (including any event procedures you've declared as Public) appear. This includes Public Sub, Public Function, Public Property Get, Public Property Let, and Public Property Set procedures. And these always appear in the vTable in the same order they appear in the code.
Once all the Public variables and Public procedures are dealt with, there is an entry for each Private/Friend procedure in the code (including event procedures). Again, after the Public procedures, these Private/Friend procedures all appear in the vTable in the order in which they appear in the code.
Skipping over the iInterfaceCount and iIntrinsicCount, let's look at an example of counting vTable entries. We'll stick with the idea that it's all in Form1, although these concepts hold for all COM module code.
Code:
Option Explicit
Private var1 As Long ' Not counted.
Public var2 As Long ' vTable entry #1 (Get) & #2 (Let).
Private var3 As Long ' Not counted.
Private Sub Form_Load() ' vTable entry #5 (an event, but doesn't matter)
' whatever
End Sub
Public Sub TestSub(arg1 As Byte) ' vTable entry #3 <--- it's PUBLIC
' whatever
End Sub
Friend Property Let TestProp(i As Long) ' vTable entry #6
' whatever
End Property
Friend Property Get TestProp() As Long ' vTable entry #7
' whatever
End Property
Private Sub Form_Click() ' vTable entry #8 (an event, but doesn't matter)
' whatever
End Sub
Public Function TestFn() As Variant ' vTable entry #4 <--- it's PUBLIC
' whatever
End Function
Friend Function AnotherFn() As Long ' vTable entry #9
' whatever
End Function
' Again, Private vs Friend doesn't matter.
If you carefully study the vTable counting rules and that Form1 code, you will (hopefully) understand.
So, to use a Private CallBack procedure, we must be able to count which vTable procedure it is (starting from 1). Then, we can use that number to get our procedure address out of the vTable. Here's the code that does that for us (with our vTable number being iCoderProcNumber): (LaVolpe's code & tips from The Trick helped me to get this sorted.)
Code:
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Public Function Vb6ComCodeObjectAddressOfByNumber(ByVal o As Object, ByVal iCoderProcNumber As Long) As Long
' The caller is responsible for knowing how to use the returned address, or crash may result.
' COM/code objects have one (or two) hidden arguments, one for the ObjPtr address, and,[
' if it's a function (or property get), another for that return. ObjPtr is first and return value is second.
'
' The iCoderProcNumber starts at 1 and can be no larger than the iCoderCodedCount returned by Vb6ComCodeObjectVtableEntries.
' The procedure number is a CODER CODED procedure, including any events.
'
Dim iInterfaceCount As Long, iIntrinsicCount As Long, iCoderCodedCount As Long
Call Vb6ComCodeObjectVtableEntries(o, iInterfaceCount, iIntrinsicCount, iCoderCodedCount)
If iCoderProcNumber < 1& Or iCoderProcNumber > iCoderCodedCount Then Exit Function ' This will catch bad objects.
'
' Return the address in the vTable.
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable ' Get pointer to start of vTable.
pVtable = pVtable + (iInterfaceCount + iIntrinsicCount) * 4& ' Jump over the interface and intrinsic entries. 4& is 4 bytes per pointer (32-bit).
pVtable = pVtable + (iCoderProcNumber - 1&) * 4& ' And now go up to our specified procedure in the vTable.
GetMem4 ByVal pVtable, Vb6ComCodeObjectAddressOfByNumber ' Pointer into actual code (the member).
End Function
Notice that this Vb6ComCodeObjectAddressOfByNumber procedure uses the prior listed Vb6ComCodeObjectVtableEntries procedure to get its work done. It needs this so it can jump over the interface and intrinsic vTable entries to get to the one of interest to us (our CallBack procedure).
Now, we've finally arrived back at a point where we can use this address along with our thunk to make CallBack calls into our COM object's procedures. And this time, we can keep them Private.
Example #4: I'll just rework the above "monitor handle" example to use this approach. Again, I'm just going to put all the code into a Form1 module.
Also, with this approach, there was nothing to tell us how many arguments the CallBack procedure had, which was needed in the call to AddressOfThunkForComProc. So, we just have to count them and hard-code this value, which is what you'll see I've done. I've also changed the CallBack procedures around to actually use the RECT type, since we can now do that, and I report the monitor dimensions in one of the callbacks.
Code:
Option Explicit
'
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
Private Declare Function vbaCheckType Lib "msvbvm60" Alias "__vbaCheckType" (ByVal pObj As Any, ByRef pIID As Any) As Boolean
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByRef lpString As Any) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByRef psz As Any, ByVal lSize As Long) As String
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'
Private Type RECT
Left As Long
Top As Long
Right As Long ' This is +1 (right - left = width)
Bottom As Long ' This is +1 (bottom - top = height)
End Type
Private Type MONITORINFO
cbSize As Long
rcMonitor As RECT
rcWork As RECT
dwFlags As Long
End Type
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hDC As Long, lprcClip As Any, ByVal lpfnEnum As Long, dwData As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As Any) As Long
'
' vTable entry #1 (of the coder procs), as it's the FIRST coder vTable item in this module ... and there are 4 arguments.
' Notice that there are no Public variables nor Public procedures in the module, or this vTable count would change.
Private Function MonitorHandleEnumCallback(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
dwData = dwData + 1& ' The actual count.
Me.Print " "; CStr(hMonitor); " Left: "; Format$(uRect.Left, "0000"); _
" Width: "; Format$(uRect.Right - uRect.Left, "0000"); _
" Top: "; Format$(uRect.Top, "0000"); _
" Height: "; Format$(uRect.Bottom - uRect.Top, "0000")
MonitorHandleEnumCallback = 1& ' Count them all.
End Function
' vTable entry #2 (of the coder procs), as it's the SECOND coder vTable item in this module ... and there are 4 arguments.
Private Function PrimaryMonitorHandleEnumCallback(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
Dim MonInfo As MONITORINFO
MonInfo.cbSize = LenB(MonInfo)
GetMonitorInfo hMonitor, MonInfo
If MonInfo.dwFlags = &H1& Then
dwData = hMonitor
PrimaryMonitorHandleEnumCallback = 0& ' Found it.
Else
PrimaryMonitorHandleEnumCallback = 1& ' Keep looking.
End If
End Function
Private Sub Form_Load()
' Form setup.
Me.AutoRedraw = True
Me.Font.Name = "Segoe UI Semibold"
Me.Font.Size = 12
' Some variables we'll use.
Dim ThunkSize As Long
Dim pVirtualMem As Long
Dim pProcAddress As Long
' First, just list our monitors.
' Get our procedure address and argument count.
pProcAddress = Vb6ComCodeObjectAddressOfByNumber(Me, 1&) ' <--- 1& is the vTable number.
' Make THUNK into executable memory.
pVirtualMem = AddressOfThunkForComProc(Me, pProcAddress, 4&, ThunkSize) ' <--- 4& is the argument count.
' Count our monitors ... their handles are listed in the callback.
Me.Print "Monitor handle(s):"
Dim iMonitorCount As Long
EnumDisplayMonitors 0&, ByVal 0&, pVirtualMem, iMonitorCount
Me.Print "Total monitor count: "; CStr(iMonitorCount)
' Give our thunk memory back.
FreeTheThunk pVirtualMem, ThunkSize
' Now let's use a callback to find our primary monitor.
' Get our procedure address and argument count.
pProcAddress = Vb6ComCodeObjectAddressOfByNumber(Me, 2&) ' <--- 2& is the vTable number.
' Make THUNK into executable memory.
pVirtualMem = AddressOfThunkForComProc(Me, pProcAddress, 4&, ThunkSize) ' <--- 4& is the argument count.
' Get primary monitor handle using callback.
Dim hPrimaryMonitor As Long
EnumDisplayMonitors 0&, ByVal 0&, pVirtualMem, hPrimaryMonitor
Me.Print "Handle of primary monitor: "; CStr(hPrimaryMonitor)
' Give our thunk memory back.
FreeTheThunk pVirtualMem, ThunkSize
End Sub
' *************************************************
' API CallBack to object ... support procedures.
' *************************************************
Private Function Vb6ComCodeObjectAddressOfByNumber(ByVal o As Object, ByVal iCoderProcNumber As Long) As Long
' The caller is responsible for knowing how to use the returned address, or crash may result.
' COM/code objects have one (or two) hidden arguments, one for the ObjPtr address, and,
' if it's a function (or property get), another for that return. ObjPtr is first and return value is second.
'
' The iCoderProcNumber starts at 1 and can be no larger than the iCoderCodedCount returned by Vb6ComCodeObjectVtableEntries.
' The procedure number is a CODER CODED procedure, including any events.
'
Dim iInterfaceCount As Long, iIntrinsicCount As Long, iCoderCodedCount As Long
Call Vb6ComCodeObjectVtableEntries(o, iInterfaceCount, iIntrinsicCount, iCoderCodedCount)
If iCoderProcNumber < 1& Or iCoderProcNumber > iCoderCodedCount Then Exit Function ' This will catch bad objects.
'
' Return the address in the vTable.
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable ' Get pointer to start of vTable.
pVtable = pVtable + (iInterfaceCount + iIntrinsicCount) * 4& ' Jump over the interface and intrinsic entries. 4& is 4 bytes per pointer (32-bit).
pVtable = pVtable + (iCoderProcNumber - 1&) * 4& ' And now go up to our specified procedure in the vTable.
GetMem4 ByVal pVtable, Vb6ComCodeObjectAddressOfByNumber ' Pointer into actual code (the member).
End Function
Private Function Vb6ComCodeObjectVtableEntries(o As Object, Optional iInterfaceCount As Long, Optional iIntrinsicCount As Long, Optional iCoderCodedCount As Long) As Long
' Return is the TOTAL, with Optional arguments returned as individual pieces.
'
If Not ObjectIsVb6ComCodeModule(o) Then Exit Function
'
Dim pVtable As Long: GetMem4 ByVal ObjPtr(o), pVtable
Dim ptObjectInfo As Long: GetMem4 ByVal pVtable - 4&, ptObjectInfo
iInterfaceCount = 7& ' IUnknown and IDispatch.
GetMem2 ByVal ptObjectInfo + &H62&, iIntrinsicCount ' Out of the tObjectInfo structure (wPCodeCount).
GetMem2 ByVal ptObjectInfo + &H60&, iCoderCodedCount ' Out of the tObjectInfo structure (wMethodLinkCount).
Vb6ComCodeObjectVtableEntries = iInterfaceCount + iIntrinsicCount + iCoderCodedCount
End Function
Private Sub FreeTheThunk(ByVal pVirtualMem As Long, ByVal iThunkSize As Long)
Const MEM_RELEASE As Long = &H8000&
VirtualFree pVirtualMem, iThunkSize, MEM_RELEASE
End Sub
Private Function AddressOfThunkForComProc(ByVal o As Object, _
ByVal ComProcAddress As Long, _
ByVal ComProcArgCount As Long, _
ByRef iThunkSize As Long) As Long
' This makes a thunk and places it into a Byte array.
' This thunk is specifically for allowing COM procedures to be called as standard BAS procedures.
'
' ComProcAddress: The actual address of the COM procedure, typically dug out of the vTable.
'
' ComObjPtr: Usually comes out of ObjPtr(TheObject) for an instantiated VB6 COM/Code object (Form, Class, UC, PropertyPage, or DataReport).
'
' ComProcArgCount: The number of arguments "seen" in the code of the COM procedure.
' It's MANDATORY that this be a number from 1 to 4 !!!!
' It is assumed all the arguments are either ByRef or 4-byte ByVal arguments.
' Anything else will fail and probably cause a crash.
'
' iThunkSize: Returned, and it must be used with VirtualFree to free this thunk memory.
' The FreeTheThunk procedure is setup for this.
'
If ComProcAddress = 0& Or ObjPtr(o) = 0& Then Exit Function
If ComProcArgCount < 1& Or ComProcArgCount > 4& Then Exit Function
Dim bb() As Byte
'
' Auto generated by Elroy's thunk maker.
ReDim bb(44)
' ;
' ; The idea here is to convert a call that thinks it's a regular BAS call
' ; into a call that can go into a COM object procedure. It is assumed that
' ; all arguments are either ByRef or 4-byte ByVal parameters. It is
' ; further assumed that it's a Function that returns a Long. This should
' ; cover the vast majority of API callbacks as well as subclassing.
' ;
' ; This thunk can handle one, two, three, or four incoming arguments.
' ; As an example, we'll assume two incoming arguments. In a BAS module,
' ; such a function would look like the following:
' ;
' ; Function OurCallBack(ByRef Arg1 As Long, ByRef Arg2 As Long) As Long
' ;
' ; When in a COM object, under the hood, this would be transformed as follows:
' ;
' ; Function OurCallBack(ByVal OurObjPtr As Long, ByRef Arg1 As Long, _
' ; ByRef Arg2 As Long, ByRef FnRet As Long) As HRESULT
' ;
' ; So, to treat it as a BAS module call, we've got to add the OurObjPtr and
' ; deal with the return as an argument. We just discard the HRESULT return.
' ;
bb(0) = &H55 ' push ebp ; Save base pointer, always done.
bb(1) = &H89: bb(2) = &HE5 ' mov ebp, esp ; Save stack pointer in ebp.
bb(3) = &H83: bb(4) = &HEC: bb(5) = &H4 ' sub esp, 4 ; Allocate 4 bytes of storage for local variables.
' ;
' ; We now start setting up for the COM procedure call.
' ;
bb(6) = &H89: bb(7) = &HE8 ' mov eax, ebp ; Base pointer into eax.
bb(8) = &H83: bb(9) = &HE8: bb(10) = &H4 ' sub eax, 4 ; Address for COM proc's FnRet to return.
bb(11) = &H50 ' push eax ; and pushed on the stack for ByRef return.
bb(12) = &HFF: bb(13) = &H75: bb(14) = &H14 ' push [ebp + 20] ; Arg4 onto stack. Possibly patch with NOP.
bb(15) = &HFF: bb(16) = &H75: bb(17) = &H10 ' push [ebp + 16] ; Arg3 onto stack. Possibly patch with NOP.
bb(18) = &HFF: bb(19) = &H75: bb(20) = &HC ' push [ebp + 12] ; Arg2 onto stack. Possibly patch with NOP.
bb(21) = &HFF: bb(22) = &H75: bb(23) = &H8 ' push [ebp + 8] ; Arg1 onto stack. At least one arg is required.
bb(24) = &H68: bb(25) = &H55: bb(26) = &H55: bb(27) = &H55: bb(28) = &H55 ' push 0x55555555 ; We'll patch this up with the OurObjPtr address.
' ;
bb(29) = &HB8: bb(30) = &H66: bb(31) = &H66: bb(32) = &H66: bb(33) = &H66 ' mov eax, 0x66666666 ; We'll patch this up with the address to the COM procedure.
bb(34) = &HFF: bb(35) = &HD0 ' call eax ; Call the COM procedure.
' ;
' ; We're back, so patch up the return from COM proc, and return.
' ; The stack will take care of itself, as ByVal are discarded,
' ; and ByRef were passed through with the same address.
' ;
bb(36) = &H8B: bb(37) = &H45: bb(38) = &HFC ' mov eax, [ebp - 4] ; Return the last argument's value as our return.
bb(39) = &H89: bb(40) = &HEC ' mov esp, ebp ; Restore stack pointer from base pointer.
bb(41) = &H5D ' pop ebp ; Restore base pointer.
bb(42) = &HC2: bb(43) = &H8: bb(44) = &H0 ' ret 8 ; Reset stack (for passed args) and return. Patch up 8 for exact number of args (x 4).
'
' We will need the size.
iThunkSize = UBound(bb) - LBound(bb) + 1&
'
' If not four arguments, blank out unused.
If ComProcArgCount < 4& Then bb(12) = &H90: bb(13) = &H90: bb(14) = &H90 ' &H90 = NOP (no operation)
If ComProcArgCount < 3& Then bb(15) = &H90: bb(16) = &H90: bb(17) = &H90
If ComProcArgCount < 2& Then bb(18) = &H90: bb(19) = &H90: bb(20) = &H90
' At least one argument is required, so bb(21) thru bb(23) don't change.
'
' Patch up our two supplied addresses.
CopyMemory bb(25), ObjPtr(o), 4& ' The ObjPtr() that's needed as an argument.
CopyMemory bb(30), ComProcAddress, 4& ' Where the actual call to the COM procedure is being made.
'
' Patch up the return for how much of the stack to reset.
bb(43) = ComProcArgCount * 4&
'
' Get some executable memory. Make sure we release it when we're done.
Const MEM_COMMIT As Long = &H1000&
Const PAGE_EXECUTE_READWRITE As Long = &H40&
AddressOfThunkForComProc = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'
' Move thunk into executable memory, and return our virtual memory's address.
CopyMemory ByVal AddressOfThunkForComProc, bb(0&), iThunkSize
End Function
Private Function ObjectIsVb6ComCodeModule(ByRef o As IUnknown) As Boolean
' If it's an instantiated Class, Form, UC, PropPage, DataReport, returns TRUE, else FALSE.
If ObjPtr(o) = 0& Then Exit Function ' Make sure "something" is instantiated.
Dim aGUID(1&) As Currency ' Just to get 16 easily accessible bytes.
aGUID(0&) = 128347367577987.1845@ ' Const AreYouABasicInstance As String = "{0B6C9465-D082-11CF-8B4F-00A0C90F2704}"
aGUID(1&) = 29922525889064.5387@ ' turned into two numbers stuffed into our Currency array.
ObjectIsVb6ComCodeModule = vbaCheckType(o, aGUID(0&)) ' Check and see if we are this "TYPE" (Class, Form, UC, PropPage, or DataRep).
End Function
Be sure to notice the use of Vb6ComCodeObjectAddressOfByNumber rather than Vb6ComCodeObjectAddressOf.
And here's what the output looks like:
-
Re: API CallBacks Using an Object's Procedure
Review:
Ok, that's about it. Let's review a bit and I'll also give you a ZIP file with all the support procedures we've discussed.
Support Procedures We've Discussed:
- ObjectIsVb6ComCodeModule
- VtableOffsetForVb6ComMethod
- Vb6ComCodeObjectAddressOf
- AddressOfThunkForComProc
- FreeTheThunk
- Vb6ComCodeObjectVtableEntries
- Vb6ComCodeObjectAddressOfByNumber
And here's a zipped BAS file with all of these, including their API support: Attachment 186075 (CallingVb6ObjectsWithByNum.BAS)
These are in a BAS, and they're all declared as Public. But don't forget that they can be pulled into any VB6 code object (Form, Class, UserControl, PropPage, or DataReport) and declare as Private, therefore wrapping everything up into a single module ... which is really the whole objective of this.
And just to review the steps to using it all:
If you're willing to declare your CallBack procedure(s) as Public:
- Use Vb6ComCodeObjectAddressOf to get your COM procedure address and argument count.
- Use AddressOfThunkForComProc to make a thunk, getting its address (and size).
- Make your API callback call, using the thunk address for the callback address.
- When done making callbacks, use FreeTheThunk to free the thunk's memory.
If you must declare your CallBack procedure(s) as Private:
- Use the outlined rules (above) to figure out the coder's vTable entry number for your callback procedure.
- Use Vb6ComCodeObjectAddressOfByNumber to get your COM procedure address.
- Count the argument(s) in your callback procedure.
- Use AddressOfThunkForComProc to make a thunk, getting its address (and size).
- Make your API callback call, using the thunk address for the callback address.
- When done making callbacks, use FreeTheThunk to free the thunk's memory.
Some Friendly Advice:
If/when I want to use this stuff, I'll always be "debugging" my CallBack testing by using a regular BAS module for the CallBack procedure. Then, once I've got all that running the way I'd like, then I'll move it all into my COM (Class, Form, etc.) module. That way, if something doesn't work, you'll know whether it was your coding of the CallBack, or your implementation of these CallBack-in-COM procedures.
Enjoy,
Elroy
-
Re: API CallBacks Using an Object's Procedure
Addendum:
I just realized that subclassing with ComCtl32 requires a callback with 6 arguments. Here's the thunk procedure reworked to deal with up to six arguments. I'm not going to update all of the above just yet, but you can simply replace this AddressOfThunkForComProc with the one below if you have a need for 5 or 6 arguments in your CallBack. Otherwise, the one above will work fine.
Code:
Private Function AddressOfThunkForComProc(ByVal o As Object, _
ByVal ComProcAddress As Long, _
ByVal ComProcArgCount As Long, _
ByRef iThunkSize As Long) As Long
' This makes a thunk and places it into a Byte array.
' This thunk is specifically for allowing COM procedures to be called as standard BAS procedures.
'
' ComProcAddress: The actual address of the COM procedure, typically dug out of the vTable.
'
' ComObjPtr: Usually comes out of ObjPtr(TheObject) for an instantiated VB6 COM/Code object (Form, Class, UC, PropertyPage, or DataReport).
'
' ComProcArgCount: The number of arguments "seen" in the code of the COM procedure.
' It's MANDATORY that this be a number from 1 to 6 !!!!
' It is assumed all the arguments are either ByRef or 4-byte ByVal arguments.
' Anything else will fail and probably cause a crash.
'
' iThunkSize: Returned, and it must be used with VirtualFree to free this thunk memory.
' The FreeTheThunk procedure is setup for this.
'
If ComProcAddress = 0& Or ObjPtr(o) = 0& Then Exit Function
If ComProcArgCount < 1& Or ComProcArgCount > 6& Then Exit Function
Dim bb() As Byte
'
' Auto generated by Elroy's thunk maker.
ReDim bb(50)
' ;
' ; The idea here is to convert a call that thinks it's a regular BAS call
' ; into a call that can go into a COM object procedure. It is assumed that
' ; all arguments are either ByRef or 4-byte ByVal parameters. It is
' ; further assumed that it's a Function that returns a Long. This should
' ; cover the vast majority of API callbacks as well as subclassing.
' ;
' ; This thunk can handle one, two, three, four, five, or six incoming arguments.
' ; As an example, we'll assume two incoming arguments. In a BAS module,
' ; such a function would look like the following:
' ;
' ; Function OurCallBack(ByRef Arg1 As Long, ByRef Arg2 As Long) As Long
' ;
' ; When in a COM object, under the hood, this would be transformed as follows:
' ;
' ; Function OurCallBack(ByVal OurObjPtr As Long, ByRef Arg1 As Long, _
' ; ByRef Arg2 As Long, ByRef FnRet As Long) As HRESULT
' ;
' ; So, to treat it as a BAS module call, we've got to add the OurObjPtr and
' ; deal with the return as an argument. We just discard the HRESULT return.
' ;
bb(0) = &H55 ' push ebp ; Save base pointer, always done.
bb(1) = &H89: bb(2) = &HE5 ' mov ebp, esp ; Save stack pointer in ebp.
bb(3) = &H83: bb(4) = &HEC: bb(5) = &H4 ' sub esp, 4 ; Allocate 4 bytes of storage for local variables.
' ;
' ; We now start setting up for the COM procedure call.
' ;
bb(6) = &H89: bb(7) = &HE8 ' mov eax, ebp ; Base pointer into eax.
bb(8) = &H83: bb(9) = &HE8: bb(10) = &H4 ' sub eax, 4 ; Address for COM proc's FnRet to return.
bb(11) = &H50 ' push eax ; and pushed on the stack for ByRef return.
bb(12) = &HFF: bb(13) = &H75: bb(14) = &H1C ' push [ebp + 28] ; Arg6 onto stack. Possibly patch with NOP.
bb(15) = &HFF: bb(16) = &H75: bb(17) = &H18 ' push [ebp + 24] ; Arg5 onto stack. Possibly patch with NOP.
bb(18) = &HFF: bb(19) = &H75: bb(20) = &H14 ' push [ebp + 20] ; Arg4 onto stack. Possibly patch with NOP.
bb(21) = &HFF: bb(22) = &H75: bb(23) = &H10 ' push [ebp + 16] ; Arg3 onto stack. Possibly patch with NOP.
bb(24) = &HFF: bb(25) = &H75: bb(26) = &HC ' push [ebp + 12] ; Arg2 onto stack. Possibly patch with NOP.
bb(27) = &HFF: bb(28) = &H75: bb(29) = &H8 ' push [ebp + 8] ; Arg1 onto stack. At least one arg is required.
bb(30) = &H68: bb(31) = &H55: bb(32) = &H55: bb(33) = &H55: bb(34) = &H55 ' push 0x55555555 ; We'll patch this up with the OurObjPtr address.
' ;
bb(35) = &HB8: bb(36) = &H66: bb(37) = &H66: bb(38) = &H66: bb(39) = &H66 ' mov eax, 0x66666666 ; We'll patch this up with the address to the COM procedure.
bb(40) = &HFF: bb(41) = &HD0 ' call eax ; Call the COM procedure.
' ;
' ; We're back, so patch up the return from COM proc, and return.
' ; The stack will take care of itself, as ByVal are discarded,
' ; and ByRef were passed through with the same address.
' ;
bb(42) = &H8B: bb(43) = &H45: bb(44) = &HFC ' mov eax, [ebp - 4] ; Return the last argument's value as our return.
bb(45) = &H89: bb(46) = &HEC ' mov esp, ebp ; Restore stack pointer from base pointer.
bb(47) = &H5D ' pop ebp ; Restore base pointer.
bb(48) = &HC2: bb(49) = &H8: bb(50) = &H0 ' ret 8 ; Reset stack (for passed args) and return. Patch up 8 for exact number of args (x 4).
'
' We will need the size.
iThunkSize = UBound(bb) - LBound(bb) + 1&
'
' If not six arguments, blank out unused.
If ComProcArgCount < 6& Then bb(12) = &H90: bb(13) = &H90: bb(14) = &H90 ' &H90 = NOP (no operation)
If ComProcArgCount < 5& Then bb(15) = &H90: bb(16) = &H90: bb(17) = &H90
If ComProcArgCount < 4& Then bb(18) = &H90: bb(19) = &H90: bb(20) = &H90
If ComProcArgCount < 3& Then bb(21) = &H90: bb(22) = &H90: bb(23) = &H90
If ComProcArgCount < 2& Then bb(24) = &H90: bb(25) = &H90: bb(26) = &H90
' At least one argument is required, so bb(21) thru bb(23) don't change.
'
' Patch up our two supplied addresses.
CopyMemory bb(31), ObjPtr(o), 4& ' The ObjPtr() that's needed as an argument.
CopyMemory bb(36), ComProcAddress, 4& ' Where the actual call to the COM procedure is being made.
'
' Patch up the return for how much of the stack to reset.
bb(49) = ComProcArgCount * 4&
'
' Get some executable memory. Make sure we release it when we're done.
Const MEM_COMMIT As Long = &H1000&
Const PAGE_EXECUTE_READWRITE As Long = &H40&
AddressOfThunkForComProc = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'
' Move thunk into executable memory, and return our virtual memory's address.
CopyMemory ByVal AddressOfThunkForComProc, bb(0&), iThunkSize
End Function
-
Re: API CallBacks Using an Object's Procedure
Just as a funny note, I once told Wqweto that I wanted to do this in as few lines of code as possible.
This certainly isn't what this turned out to be, but hey ho. :) It gets it done.
-
Re: API CallBacks Using an Object's Procedure
Thanks for the detailed writeup, I've been wanting to understand how these things work better for a while but it's hard to follow just from code.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
fafalone
Thanks for the detailed writeup, I've been wanting to understand how these things work better for a while but it's hard to follow just from code.
No problem. And yep, that was pretty much my motivation as well. I've got a persistent debugger that I may wrap some of this stuff into, but I really just wanted to understand how it all works ... and have it (hopefully) done in a way that I can come back months later and still understand it.
ADDED: I'm really liking this stuff. I just put two subclassing procedures and a color dialog callback procedure all in a single form module (the only module now in the project). If we wish to keep everything contained within a single COM module, this does the trick.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Elroy
Just as a funny note, I once told Wqweto that I wanted to do this in as few lines of code as possible.
This certainly isn't what this turned out to be, but hey ho. :) It gets it done.
Yes, this kind of stuff has to be built-in in the language to keep the gory implementation details away from us mortals :-))
cheers,
</wqw>
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
wqweto
Yes, this kind of stuff has to be built-in in the language to keep the gory implementation details away from us mortals :-))
haha, now Wqweto, you're being too modest. You're definitely up there at least close to "programming God" status. :p Pfff, someone who's unravelled the mysteries of ZIP, modern subclassing, manifest maker, encryption, etc., etc.
Now me, on the other hand ... where I said remembering things "months later", I really meant "minutes later". :)
-
Re: API CallBacks Using an Object's Procedure
can Vb6ComCodeObjectAddressOf and AddressOfThunkForComProc be used in office vba?
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
loquat
can Vb6ComCodeObjectAddressOf and AddressOfThunkForComProc be used in office vba?
Loquat, basically, I'd say "NO".
For one, all of this was designed specifically for 32-bit memory addresses, which the VBA may or may not have (depending on your version).
Also, I've got no idea if the definitional structures I'm digging some of the pointers out of are the same in the VBA.
And sorry, but I've really got no interest in trying to make this stuff work in VBA environments.
-
Re: API CallBacks Using an Object's Procedure
This is really a great invention.Don't know how twinbasic does almost 100% cloning of VB6 IDE。。
I don't think the engineers at Microsoft have time to do this. And the developers of such an old VB6 project are also expected to have signed a confidentiality agreement with Microsoft.
-
Re: API CallBacks Using an Object's Procedure
Maybe there is a method where we can call the net object directly. Or call edgr webview directly through TLB. But the direct reference in VB6 failed. What vtable technology can be invoked
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
xiaoyao
Maybe there is a method where we can call the net object directly. Or call edgr webview directly through TLB. But the direct reference in VB6 failed. What vtable technology can be invoked
xiaoyao, I have no interest in applying any of this to .NET. Also, it's somewhat off-topic so please start a new thread over in the Q&A section for such things. Thank you. :)
-
Re: API CallBacks Using an Object's Procedure
use this ,can list all method?public and Private?
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
xiaoyao
use this ,can list all method?public and Private?
I believe I've stated this for you before. It can list Public but not Friend nor Private (at least not once compiled). You could list them all in the IDE, but I don't see much use in it if it won't work once compiled.
-
Re: API CallBacks Using an Object's Procedure
MsgBox ListVb6ComFunction(ObjPtr(Me))
ListVb6ComFunction(ObjPtr(Me), False, False) 'show all only in vb6 ide
Code:
Public Type FunctionInfo
MethodName As String
ArgCount As Long
VtableOffset As Long
IsFunction As Boolean
MethodType As String
End Type
Public FunList() As FunctionInfo
Public Function ListVb6ComFunction(ByVal ObjPtrV As Long, Optional OnlyMethod As Boolean = True, Optional PublicItem As Boolean = True) As Long
Dim MethodTypeArr(3) As String
MethodTypeArr(0) = "Method"
MethodTypeArr(1) = "Get"
MethodTypeArr(2) = "Let"
MethodTypeArr(3) = "Set"
ReDim FunList(0)
Dim sMethodName As String, lArgCount As Long, ID As Long
ID = -1
If Not ObjectIsVb6ComCodeModule_P(ObjPtrV) Then Exit Function ' Make sure we're dealing with a VB6 COM-code object.
'
Dim pVTbl As Long: GetMem4 ByVal ObjPtrV, pVTbl ' Pointer to vTable.
Dim pObjInfo As Long: GetMem4 ByVal pVTbl - 4&, pObjInfo ' Pointer to tObjectInfo structure.
Dim pPubDesc As Long: GetMem4 ByVal pObjInfo + &H18&, pPubDesc ' tObjectInfo.aObject which points to tObject structure.
Dim pPrivDesc As Long: GetMem4 ByVal pObjInfo + &HC&, pPrivDesc ' tObjectInfo.lpPrivateObject which points to tPrivateObj structure.
'
If pPrivDesc = 0& Then Exit Function ' Just a double-check.
'
Dim lIndex As Long
Dim pName As Long
'
' Search the procedures within the module.
Dim pMethDesc As Long
Dim iMethOffset As Integer
Dim bbArgs As Byte
Dim lMethodsCnt As Long: GetMem2 ByVal pPubDesc + &H1C&, lMethodsCnt ' tObject.ProcCount value.
Dim pNames As Long: GetMem4 ByVal pPubDesc + &H20&, pNames ' tObject.aProcNamesArray which points to an array of name pointers.
Dim pMethodsPtr As Long: GetMem4 ByVal pPrivDesc + &H18&, pMethodsPtr ' tPrivateObj.lpFuncTypeInfo which points to an array of pointers.
Dim NewFunName As String
' Loop through methods and see if we can find the one we want.
For lIndex = 0& To lMethodsCnt - 1&
GetMem4 ByVal pMethodsPtr + lIndex * 4&, pMethDesc ' From the array, getting a pointer to a method structure (tMethInfo).
If pMethDesc Then ' Not sure if this ever returns zero, maybe for "Private" methods?
GetMem2 ByVal pMethDesc + 2&, iMethOffset ' Out of tMethInfo structure.
GetMem1 ByVal pMethDesc, bbArgs ' First two bits of bbArgs are: set=3, get=1, let=2, method=0 (Sub or Fn).
If OnlyMethod = False Or (bbArgs And CByte(3)) = CByte(0) Then 'if 2 ' Make sure it's a method.
If PublicItem = False Or iMethOffset And 1 Then ' First bit, 1=Public.
GetMem4 ByVal pNames + lIndex * 4&, pName ' Dig pointer to method name from array of name pointers.
ID = ID + 1
ReDim Preserve FunList(ID) 'new item>>>>
NewFunName = SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))
FunList(ID).MethodName = NewFunName
FunList(ID).MethodType = MethodTypeArr(bbArgs And CByte(3))
Form1.List1.AddItem NewFunName
FunList(ID).VtableOffset = CLng(iMethOffset And &HFFFC) ' First two bits are something else (first is Public=1,Private=0).
Dim bbFlags As Byte: GetMem1 ByVal pMethDesc + 1&, bbFlags ' Both bbArgs & bbFlags out of tMethInfo structure.
bbFlags = bbFlags And CByte(1) ' 0 (no return), 1 (return).
FunList(ID).IsFunction = bbFlags
lArgCount = CLng(bbArgs \ CByte(4) - bbFlags) ' Calculate arguments, excluding any return argument. Tested for vbGet, vbLet, vbSet, vbMethod (both Function & Sub).
FunList(ID).ArgCount = lArgCount
Debug.Print lIndex + 1 & ">ID=" & ID & " " & IIf(FunList(ID).IsFunction, "Function ", "Sub ") & NewFunName & "(" & IIf(FunList(ID).ArgCount > 0, "Args=" & lArgCount, "") & ")--" & FunList(ID).MethodType
End If
End If 'if 2 end
End If
Next
ListVb6ComFunction = ID
End Function
-
Re: API CallBacks Using an Object's Procedure
How is that relevant to the purpose of this thread? It seems like you want to talk about something else, not what this thread is about.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Shaggy Hiker
How is that relevant to the purpose of this thread? It seems like you want to talk about something else, not what this thread is about.
Get more vtable related information from these memory addresses. For example, there are more LET, SET, GET and other information. Make spiritual use of this knowledge and use as many resources as possible, maybe someone will use it in the future.
In fact, the address of the private function can be perfectly analyzed in the IDE, and the private function cannot be viewed after the EXE is generated, but as long as the virtual table offset is known, the private function can also be used. It is enough to save these unreadable offset data in the resource file or INI configuration.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Shaggy Hiker
How is that relevant to the purpose of this thread? It seems like you want to talk about something else, not what this thread is about.
Thanks for trying. :)
-
Re: API CallBacks Using an Object's Procedure
This is marvellous!
Thanks very much
Lets see if you can break the next limitation...
Private Enum and user-defined types cannot be used as parameters or return types for public procedures, public data members, or fields of public user-defined types
I have a function Returning its value as a UDT, i need to make the UDT and the Function Public
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Semke
This is marvellous!
Thanks very much
Lets see if you can break the next limitation...
Private Enum and user-defined types cannot be used as parameters or return types for public procedures, public data members, or fields of public user-defined types
I have a function Returning its value as a UDT, i need to make the UDT and the Function Public
Just like the CDECL keyword plug-in, it needs 8000 lines of code. Maybe your problem can also be solved with compiler patching, but the cost is too high, it may cost thousands of dollars or more, and it is not necessary.
For 99% of the usage scenarios, you can turn the module file into a CLASS class object, and you only need to use NEW CLASSx once.
Replace the data structure with CLASS. Or use a TLB file to write a data structure you need, then it can be used in modules or classes.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Semke
This is marvellous!
Thanks very much
Lets see if you can break the next limitation...
Private Enum and user-defined types cannot be used as parameters or return types for public procedures, public data members, or fields of public user-defined types
I have a function Returning its value as a UDT, i need to make the UDT and the Function Public
I'm not exactly sure what you're asking. I don't have any problems with Public Enum blocks.
Regarding UDTs, if they're public, just make sure your class procedures are declared as Friend, and then you can pass them in and out.
The only got-cha is if you want to put UDTs into a Variant (or as data in a Collection). In this case, you need to put your UDTs into a TypeLib (.tlb file), and then reference that file in your project. I actually wrote a pure VB6 utility to create these UDT typelibs precisely for this reason.
It can be found here.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Elroy
The only got-cha is if you want to put UDTs into a Variant (or as data in a Collection). In this case, you need to put your UDTs into a TypeLib (.tlb file), and then reference that file in your project. I actually wrote a pure VB6 utility to create these UDT typelibs precisely for this reason.
.
Very useful function, thank you for your great efforts, adding new vitality to VB6
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Elroy
I believe I've stated this for you before. It can list Public but not Friend nor Private (at least not once compiled). You could list them all in the IDE, but I don't see much use in it if it won't work once compiled.
It is also useful after compilation. For example, the offset of the private procedure is 120, and the offset of the last public function is 116, then only 120 can be used to access the address of the private function. Just need to save the addresses of these private functions as INI or other files, so that the compiled EXE can read the information
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Elroy
I'm not exactly sure what you're asking. I don't have any problems with Public Enum blocks.
Regarding UDTs, if they're public, just make sure your class procedures are declared as Friend, and then you can pass them in and out.
The only got-cha is if you want to put UDTs into a Variant (or as data in a Collection). In this case, you need to put your UDTs into a TypeLib (.tlb file), and then reference that file in your project. I actually wrote a pure VB6 utility to create these UDT typelibs precisely for this reason.
Looks like I didn't make myself clear.
i am referring to UDT's only
The beauty of these functions are, that you can have one class, which contains the entire code required for it's use. no more dependent .BAS files.
I know that I can declare the UDT in a TypeLib or in another .BAS file. I was trying to avoid that and have all the code including UDT's in the same Module.
-
Re: API CallBacks Using an Object's Procedure
Function AddressOfThunkForComProc(ByVal o As Object, _
how to change to any arg count?
0 args,1-20 args?
GetClassProcAddr IS USE for settimer api callback,can you fix this to useon vb6 forms/class/usercontrol?
How to support arbitrary number of parameters? I want to replace it with this method, but it crashes after the callback
Code:
Private Function GetClassProcAddr(ByVal Index As Long, Optional ParamCount As Long = 4, Optional HasReturnValue As Boolean) As Long
'GetClassProcAddr, Index is the number of public methods plus N private methods
Static lReturn As Long, pReturn As Long
Static AsmCode(50) As Byte
Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long
pThis = ObjPtr(Me)
CopyMemory pVtbl, ByVal pThis, 4
CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4
pReturn = VarPtr(lReturn)
For i = 0 To UBound(AsmCode)
AsmCode(i) = &H90
Next
AsmCode(0) = &H55
AsmCode(1) = &H8B: AsmCode(2) = &HEC
AsmCode(3) = &H53
AsmCode(4) = &H56
AsmCode(5) = &H57
If HasReturnValue Then
AsmCode(6) = &HB8
CopyMemory AsmCode(7), pReturn, 4
AsmCode(11) = &H50
End If
For i = 0 To ParamCount - 1
AsmCode(12 + i * 3) = &HFF
AsmCode(13 + i * 3) = &H75
AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
Next
i = i * 3 + 12
AsmCode(i) = &HB9
CopyMemory AsmCode(i + 1), pThis, 4
AsmCode(i + 5) = &H51
AsmCode(i + 6) = &HE8
CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4
If HasReturnValue Then
AsmCode(i + 11) = &HB8
CopyMemory AsmCode(i + 12), pReturn, 4
AsmCode(i + 16) = &H8B
AsmCode(i + 17) = &H0
End If
AsmCode(i + 18) = &H5F
AsmCode(i + 19) = &H5E
AsmCode(i + 20) = &H5B
AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5
AsmCode(i + 23) = &H5D
AsmCode(i + 24) = &HC3
GetClassProcAddr = VarPtr(AsmCode(0))
End Function
Code:
iThunkSize = 60
GetClassProcAddr = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'
' Move thunk into executable memory, and return our virtual memory's address.
CopyMemory ByVal GetClassProcAddr, AsmCode(0), 51 ' iThunkSize
-
Re: API CallBacks Using an Object's Procedure
xiaoyao,
That assembly thunk is currently written to accommodate anywhere from 0 to 6 arguments. If you need more, you'll have to rework that assembly thunk yourself. Personally, I can't imagine what you're doing that would require so many arguments, as this whole thing is just for API callbacks (including subclassing). I know of no callbacks that return 20 arguments.
-
Re: API CallBacks Using an Object's Procedure
I HOPE IT'S CAN AUTO PUSH ARGS?
like this?
Code:
GetClassProcAddr(ByVal Index As Long, Optional ParamCount As Long = 4,
For i = 0 To ParamCount - 1
AsmCode(12 + i * 3) = &HFF
AsmCode(13 + i * 3) = &H75
AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
Next
Yesterday I spent half a day switching to another plan. It would be perfect if it supports 0 - any number of arguments
Code:
get :pProcAddress
pVTable = VTable + iVoffset ' Address to our method in the vTable.
GetMem4 ByVal pVTable, pProcAddress
WebView_Offset(1).OnTitleChange_Offset=iVoffset
MakeFunction pProcAddress, AddressOf Asm_onUrlChange
Code:
Sub Module_OnTitleChange(ByVal WebId As Long, ByVal ObjPtr1 As Long, ByVal title As Long)
Asm_OnTitleChange ObjPtr1, WebId, 0&, title
End Sub
Sub Asm_OnTitleChange(ByVal This As Long, ByVal WebId As Long, ByVal ObjPtr1 As Long, ByVal title As Long)
'run in vb6 ide ,use CallCOMInterface(form1,OnTitleChange address)
'run in exe will use jmp to fom1.OnTitleChange ,not use CallCOMInterface
'like call Form1.OnTitleChange public Sub
'like Call Class1.OnTitleChange
CallCOMInterface& This, WebView_Offset(WebId).OnTitleChange_Offset, WebId, ObjPtr1, title
End Sub
Public Function MakeFunction(ComOrDllFunAddr As Long, MoudleBasFun As Long)
Dim Code(5) As Byte, JmpBackAddr As Long, OldProtect As Long
VirtualProtect ByVal ComOrDllFunAddr, 5, 64, OldProtect '更改函数地址所在页面属性
JmpBackAddr = ComOrDllFunAddr - MoudleBasFun - 5
Code(0) = &HE9
CopyMemory Code(1), JmpBackAddr, 4
WriteProcessMemory -1, ByVal MoudleBasFun, Code(0), 5, 0
End Function
-
Re: API CallBacks Using an Object's Procedure
it's the best code,support any arg count(0-100)
pFunc =pProcAddress (address of com public sub)
Code:
Function GetClassProcAddrEx(Object1 As Object, ByVal pFunc As Long, ByVal ParamCount As Long, iThunkSize As Long, Optional HasReturnValue As Boolean) As Long
'GetClassProcAddr,Index 是，第几个公共方法加N个私有方法
Dim AsmCode(50) As Byte
Const MEM_COMMIT As Long = &H1000&
Const PAGE_EXECUTE_READWRITE As Long = &H40&
iThunkSize = 24 + 24 + 1
If iThunkSize > UBound(AsmCode) + 1 Then iThunkSize = UBound(AsmCode) + 1
Dim vaddress As Long
vaddress = VirtualAlloc(0&, iThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
'================
Static lReturn As Long, pReturn As Long
Dim i As Long, pThis As Long, pVtbl As Long
pThis = ObjPtr(Object1)
pReturn = VarPtr(lReturn)
For i = 0 To UBound(AsmCode)
AsmCode(i) = &H90
Next
AsmCode(0) = &H55
AsmCode(1) = &H8B: AsmCode(2) = &HEC
AsmCode(3) = &H53
AsmCode(4) = &H56
AsmCode(5) = &H57
If HasReturnValue Then
AsmCode(6) = &HB8
CopyMemory AsmCode(7), pReturn, 4
AsmCode(11) = &H50
End If
For i = 0 To ParamCount - 1
AsmCode(12 + i * 3) = &HFF
AsmCode(13 + i * 3) = &H75
AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
Next
i = i * 3 + 12
AsmCode(i) = &HB9
CopyMemory AsmCode(i + 1), pThis, 4
AsmCode(i + 5) = &H51
AsmCode(i + 6) = &HE8
CopyMemory AsmCode(i + 7), pFunc - (vaddress + i + 6) - 5, 4
'CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4
If HasReturnValue Then
AsmCode(i + 11) = &HB8
CopyMemory AsmCode(i + 12), pReturn, 4
AsmCode(i + 16) = &H8B
AsmCode(i + 17) = &H0
End If
AsmCode(i + 18) = &H5F
AsmCode(i + 19) = &H5E
AsmCode(i + 20) = &H5B
AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5
AsmCode(i + 23) = &H5D
AsmCode(i + 24) = &HC3
'GetClassProcAddr = VarPtr(AsmCode(0))
CopyMemory ByVal vaddress, AsmCode(0), iThunkSize ' iThunkSize
GetClassProcAddrEx = vaddress
End Function
-
Re: API CallBacks Using an Object's Procedure
just tried subclassing. all works fine, as soon as i close the program vb crashes.
am i missing anything?
-
Re: API CallBacks Using an Object's Procedure
This thread isn't about subclassing but if it crashes your IDE then probably you didn't remove subclassing on exit, either manually or automatically on "WM_NCDESTROY".
-
Re: API CallBacks Using an Object's Procedure
Semke, as VanGogh says, this thread isn't exactly about subclassing ... but it could be used for subclassing.
In fact, since I've developed this, I've used this approach several times to do subclassing, wholly contained within a class object (no BAS needed), and it has always worked fine for me.
To figure out why it's not working for you, I/we would need to see some code with an example that crashes your IDE.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Elroy
Addendum:I just realized that subclassing with ComCtl32 requires a callback with 6 arguments. Here's the thunk procedure reworked to deal with up to six arguments.
Hi there. I found this little gem today and i've been checking it out. A minor question about the Addendum. In the code you present in this post, there is a comment in ComProcArgCount: "It's MANDATORY that this be a number from 1 to 4 !!!!". Shouldn't this be 6, or the other 2 are reserved for something else?
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
VB.6
Hi there. I found this little gem today and i've been checking it out. A minor question about the Addendum. In the code you present in this post, there is a comment in ComProcArgCount: "It's MANDATORY that this be a number from 1 to 4 !!!!". Shouldn't this be 6, or the other 2 are reserved for something else?
It should be 6. Thanks for catching that. I fixed the comment, but only in post #7 (the Addendum post). I didn't change it in the previous posts (OP & examples) because that thunk code is still limited to 4. It's only when you use the thunk code from post #7 that the argument count max is expanded to 6.
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
Elroy
I fixed the comment, but only in post #7 (the Addendum post).
Quote:
Originally Posted by
Elroy
It's only when you use the thunk code from post #7 that the argument count max is expanded to 6.
Yup, that's what i had understood. The Addendum extends the code from 4 params to 6. :thumb:
-
Re: API CallBacks Using an Object's Procedure
Public variables as Variant|StdFont... maybe 3 vTable entries.
-
Re: API CallBacks Using an Object's Procedure
Hello, I am the original author of GetClassProcAddress.
I recently developed a small IDE plugin, and accidentally came across this thread while searching for data. I noticed you are discussing how to retrieve function addresses in class modules – I once spent quite a bit of time figuring this out myself. If you'd like me to offer any advice, please feel free to let me know.
Funny enough, since I developed this technology around 15 or 16 years ago, some details are a bit fuzzy now. However, when I write small programs for my own use, I still use iSucClass.cls (implemented with GetClassProcAddress) for subclassing. So I still remember the core technical principles, and I have my original blog post that can help jog my memory.
I'm really glad to register on this forum for the first time, and also found such a comprehensive WinAPI declaration library!
-
Re: API CallBacks Using an Object's Procedure
Quote:
Originally Posted by
nbdld
Hello, I am the original author of GetClassProcAddress.
I recently developed a small IDE plugin, and accidentally came across this thread while searching for data. I noticed you are discussing how to retrieve function addresses in class modules – I once spent quite a bit of time figuring this out myself. If you'd like me to offer any advice, please feel free to let me know.
Funny enough, since I developed this technology around 15 or 16 years ago, some details are a bit fuzzy now. However, when I write small programs for my own use, I still use iSucClass.cls (implemented with GetClassProcAddress) for subclassing. So I still remember the core technical principles, and I have my original blog post that can help jog my memory.
I'm really glad to register on this forum for the first time, and also found such a comprehensive WinAPI declaration library!
I appreciate your offer, but I believe it's all figured out in the above, with, hopefully, self-explanatory comments for anyone's edification. Also, it's not quite as simple as getting the address of a class procedure. There's also the issue of 'implicit' arguments on the stack when calling a class's procedure, which is all discussed in the above ... specifically in the thunk included in the above.
-
Re: API CallBacks Using an Object's Procedure
good job :thumb:
I still roughly remember the situation being like this:
Retrieving the address isn’t the hard part. What you get from the vtable is the address of a jump table – it’s a jmp class.xxx instruction.
You can read the value of this class.xxx and then fetch the exact final address.
However, you can’t call it directly due to the presence of implicit parameters. You have to construct a dedicated forwarding function through a thunk.
A small piece of advice:
From my experience, it’s best to store this thunk function in a module-level array variable.
byebye :wave:
