vb6 functionPtr 函数指针 CallbyName CallbyAddress 虚函数 Matthew Curland的VB函数指针调用

'本文首发于水木清华BBS MicrosoftTRD版，转载请保留有关信息
 
'作者chen3feng([e-mail])
'email: [e-mail], [e-mail]

''贼强的东东，今天一天就为了找这个了呢，还好遇见了这个，试用了下，可以的
'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_pFunc
End Sub