VB6 functionptr function pointer callbyname callbyaddress virtual function Matthew Curland VB function pointer call

'The article was first published in shuimu Tsinghua BBS microsofttrd. Please keep the relevant information

'Chen3feng (RoachCock@smth.org)
'Email: chen3feng@163.com, chen3fengx@hotmail.com

''Well, I have been looking for this one day today. Fortunately, I met this and tried it. Yes.
'2017-12-09 reference; Vb function pointer call of Matthew Curland
'This method does not work if the parameter type is incorrect when the function has exit. Exit judgment, there will be an endless loop.

Option explicit

Private const dispatch_method = & H1
Private const locale_system_default = & h800
Private const dispid_value = 0

Private Enum callconv
Cc_fastcall = 0
Cc_cdecl = 1
Cc_mscpascal = cc_cdecl + 1
Cc_pascal = cc_mscpascal
Cc_macpascal = cc_pascal + 1
Cc_stdcall = cc_macpascal + 1
Cc_fpfastcall = cc_stdcall + 1
Cc_syscall = cc_fpfastcall + 1
Cc_mpwcdecl = cc_syscall + 1
Cc_mpwpascal = cc_mpwcdecl + 1
Cc_max = cc_mpwpascal + 1
End Enum

Private type paramdata
Szname as string
VT as varianttypeconstants
End type

Private type methoddata
Szname as string
Ppdata as long '/* pointer to an array of paramdatas */
Dispid as long '/* method ID */
Imeth as long '/* method Index */
Cc as callconv '/* calling convention */
Cargs as long '/* count of arguments */
Wflags as integer '/* same wflags as on idispatch: invoke ()*/
Vtreturn as integer
End type

Private type interfacedata
Pmethdata as long '/* pointer to an array of methoddatas */
Cmembers as long
End type

''Creates a type information based on the specified description data.
Private declare function createdisptypeinfo lib "oleaut32" (byref pidata as interfacedata, byval lcid as long, byref pptinfo as iunknown) as long
''Creates an idispatch pointer using the given interface and type information. // The VB object type corresponds to the VC idispatch smart pointer.
Private declare function createstddispatch lib "oleaut32" (byval punkouter as iunknown, byref pvthis as delegator, byval ptinfo as iunknown, byref ppunkstddisp as iunknown) as long

Private type vtable
Pthunk as long 'points to a thunk function written in x86 machine language. Of course, I first wrote it in VC and copied the machine code.
End type

Private type delegator
Pvtbl as long 'virtual function table pointer
Pfunc as long 'a data member, which is the pointer to the function to be called
End type

Private m_thunk (5) as long

Private m_vtable as vtable
Private m_delegator as delegator
Private m_interfacedata as interfacedata
Private m_methoddata as methoddata
Private m_paramdata () as paramdata
Private m_functionptr as object

Public Function create (byval pfunc as long, byval rettype as varianttypeconstants, paramarray paramtypes () as variant) as object

If typename (m_functionptr) <> "nothing" then
Set create = m_functionptr
Exit Function
End if

Dim I as long
Dim P as long
Dim cparam as long
Cparam = ubound (paramtypes) + 1

Redim m_paramdata (cparam)

If cparam then
For I = 0 to cparam-1
M_paramdata (I). Vt = paramtypes (I)
M_paramdata (I). szname = ""
Next
End if
M_methoddata.szname = "INVOKE"
M_methoddata.ppdata = varptr (m_paramdata (0 ))
M_methoddata.dispid = dispid_value
M_methoddata.imeth = 0
M_methoddata.cc = cc_stdcall
M_methoddata.cargs = cparam
M_methoddata.wflags = dispatch_method
M_methoddata.vtreturn = rettype

M_interfacedata.pmethdata = varptr (m_methoddata)
M_interfacedata.cmembers = 1

Dim Ti as iunknown
Dim result as iunknown
Set result = nothing
I = createdisptypeinfo (m_interfacedata, locale_system_default, Ti)
If I = 0 then
M_vtable.pthunk = varptr (m_thunk (0 ))

M_delegator.pvtbl = varptr (m_vtable) 'virtual function pointer, pointing to virtual table
M_delegator.pfunc = pfunc
P = varptr (m_interfacedata)
P = varptr (m_delegator)
I = createstddispatch (nothing, m_delegator, Ti, result)
If I = 0 then
Set m_functionptr = Result
Set create = m_functionptr
End if
End if
End Function

''2008-12-10 linyee add
Public property get object () as object
Set object = m_functionptr
End Property

Private sub class_initialize ()
'Thunk machine code, plus NOP is for clarity
M_thunk (0) = & hsf-4c8b 'mov ECx, [esp + 4] Get This pointer
M_thunk (1) = & h9004418b 'mov eax, [ECx + 4] NOP get m_pfunc
M_thunk (2) = & h90240c8b 'mov ECx, [esp] NOP get return address
M_thunk (3) = & hsf-4c89 'mov [esp + 4], ECx save return address
M_thunk (4) = & h9004c483 'add ESP, 4 NOP re-adjust Stack
M_thunk (5) = & h9090e0ff 'jmp eax jump to m_pfunc
End sub