'本文首发于水木清华BBS MicrosoftTRD版，转载请保留有关信息

'作者chen3feng(RoachCock@smth.org)
'email: chen3feng@163.com,chen3fengx@hotmail.com

''贼强的东东，今天一天就为了找这个了呢，还好遇见了这个，试用了下，可以的
'2008-12-09 参考；Matthew Curland的VB函数指针调用
'本法，函数内有EXIT时，参数类型不对路时，无法作用。EXIT的判断，会出现死循环。

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

''过指定的描述数据创建一个类型信息
Private Declare Function CreateDispTypeInfo Lib "oleaut32" (ByRef pidata As INTERFACEDATA,ByVal lcid As Long,ByRef pptinfo As IUnknown) As Long
''通过给定的接口和类型信息创建一个IDispatch指针 // VB的Object类型对应于VC的IDispatch智能指针
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 '指向一个x86机器语言编写的thunk函数,当然，我是先用VC写，在把机器码抄下来的
End Type

Private Type Delegator
pVtbl As Long '虚函数表指针
pFunc As Long '一个数据成员，在此为需要调用的函数的指针
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) '虚拟函数指针，指向虚拟表
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添加
Public Property Get Object() As Object
Set Object = m_FunctionPtr
End Property

Private Sub Class_Initialize() 'thunk的机器码,加nop是为了清晰 m_Thunk(0) = &H4244C8B 'mov ecx,[esp+4] 获得this pointer m_Thunk(1) = &H9004418B 'mov eax,[ecx+4] nop 获得m_pFunc m_Thunk(2) = &H90240C8B 'mov ecx,[esp] nop 得到返回地址 m_Thunk(3) = &H4244C89 'mov [esp+4],ecx 保存返回地址 m_Thunk(4) = &H9004C483 'add esp,4 nop 重新调整堆栈 m_Thunk(5) = &H9090E0FF 'jmp eax 跳转到m_pFuncEnd Sub