vb6 functionPtr 函數指標 CallbyName CallbyAddress 虛函數 Matthew Curland的VB函數指標調用

'本文首發於水木清華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_pFunc
End Sub