利用动态创建自动化接口实现VB的函数指针调用

发信人: RoachCock (chen3feng), 信区: MicrosoftTRD
标  题: 我的 VB的函数指针调用
发信站: BBS 水木清华站 (Fri Jan  3 14:54:25 2003), 转信
 
本文首发于水木清华BBS MicrosoftTRD版，转载请保留有关信息
 
作者chen3feng(RoachCock@smth.org)
email: chen3feng@163.com, chen3fengx@hotmail.com
 
 
前几天在CSDN文档中心见了一篇 Matthew Curland的VB函数指针调用，它是用的动态创建自定义接口指针
然后回掉其某个方法,不过这种方法虽然效率高，但是每一种函数需要创建一个自定义接口
类型，还得使用IDL语言，实在算不上方便，昨天我尝试出来一种方案，那就是动态创建自
动化接口指针。虽然效率低，但是其灵活性足以弥补这个弱点. 
 
我只动用两个API
为此我用了两个OLE API:
 
Private Declare Function CreateDispTypeInfo Lib "oleaut32" (ByRef pidata As _
 INTERFACEDATA, ByVal lcid As Long, ByRef pptinfo As IUnknown) As Long
 
Private Declare Function CreateStdDispatch Lib "oleaut32" (ByVal punkOuter _
As IUnknown, ByRef pvThis As Delegator, ByVal ptinfo As IUnknown, ByRef _
ppunkStdDisp As IUnknown) As Long
 
前一个函数通过指定的描述数据创建一个类型信息，后者则通过给定的接口和类型信息创
建一个IDispatch指针 // VB的Object类型对应于VC的IDispatch智能指针
 
为了创建类型信息，需要填写一个数据结构，因此需要从oleaut.h引入常数，类型，函数
声明，就不再一一细述了。关于这两个API的详细资料请参考MSDN
 
实现方法
首先我们需要模拟C++中的类的结构，我们需要一个自定义结构来表示对象，
'代理对象
Private Type Delegator
    pVtbl As Long       '虚函数表指针
    pFunc As Long       '一个数据成员，在此为需要调用的函数的指针
End Type
 
'虚函数表
Private Type VTable
    pThunk As Long      '指向一个x86机器语言编写的thunk函数,当然，我是先用VC
End Type                '写，在把机器码抄下来的
 
thunk的汇编代码如下:
    '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 
  

创建的这个方法的名字叫Invoke, dispid为0，也就是说，可以不通过成员直接调用
 
示例代码
Private Sub Form_Load()
    Dim p As FunctionPtr
    Set p = New FunctionPtr
    Dim d As Object
    Set d = p.Create(AddressOf Test, vbEmpty, vbString)
    'Test是一个标准模块函数
    d.Invoke "hehe"
    d "hehe"           ' 可以省略Invoke
 
    '调用Win32 API MessageBoxW
    Dim hModUser32
    Dim pMessageBoxW As Long
    hModUser32 = GetModuleHandle("User32")
    pMessageBoxW = GetProcAddress(hModUser32, "MessageBoxW")
    Dim mbw As New FunctionPtr
    Dim MessageBoxW As Object
    Set MessageBoxW = mbw.Create(pMessageBoxW, VT_I4, VT_I4, VT_BSTR, _
        VT_BSTR, VT_I4)
    MessageBoxW 0, "hehe,form MessageBoxW", "", 0       '可以省略Invoke
End Sub
'编译以上代码需要引入类型库操作库
 
需要说明的是,由于Oleaut32只支持对自动化兼容类型进行转换，因此只能使用自动化兼容类型
 
另外，由于VB的类不支持聚合，因此CreateStdDispatch的第一个参数外部IUnknown指针
参数不能使用，这也就意味着FunctionPtr对象必须保证在通过Create方法获取的自动化
接口指针生存期内有效，这一点算是个遗憾吧
 
虽然调试期间广泛使用了VC,但是作完了就不需要了，也不需要额外的动态连接库
只需要把FunctionPtr类模块加入工程，创建一个FunctionPtr类型的对象，调用Create
就可以得到能用来回掉的自动化对象
Create的第一个参数为函数指针，第二个为函数返回值得类型，后面的不定个数的参数
是函数的参数的类型.用起来很简单
 
 
源代码，包括完整的测试Project
'FunctionPtr.cls        '函数指针类的定义
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "FunctionPtr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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
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
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

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

'Helper.cls     '其实不是Helper,只是原来的名字而已，包含供测试的函数
Attribute VB_Name = "Helper"
Option Explicit

Sub Test1(ByRef this As Long)
    MsgBox "Test1", vbOKOnly, "hehe"
End Sub

Sub Test(ByVal s As String)
    MsgBox s, vbOKOnly, "hehe"
End Sub
  
 
'测试程序 
Option Explicit

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Sub Form_Load()
    Dim p As FunctionPtr
    Set p = New FunctionPtr
   
    Dim d As Object
    Set d = p.Create(AddressOf Test, vbEmpty, vbString)
   
    d.Invoke ("hehe")
   
    Dim hModUser32
    Dim pMessageBoxW As Long
   
    hModUser32 = GetModuleHandle("User32")
    pMessageBoxW = GetProcAddress(hModUser32, "MessageBoxW")
    Dim mbw As New FunctionPtr
    Dim MessageBoxW As Object
    Set MessageBoxW = mbw.Create(pMessageBoxW, vbLong, vbLong, vbString, vbString, vbLong)
    'MessageBoxA 0, "hehe,form MessageBoxA", "", 0
    MessageBoxW.Invoke 0, "hehe,form MessageBoxW", "", 0
End Sub
  
 
'Project文件
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\SYSTEM\
STDOLE2.TLB#OLE Automation
Form=Form1.frm
Module=Helper; Helper.bas
Class=FunctionPtr; FunctionPtr.cls
IconForm="Form1"
Startup="Form1"
HelpFile=""
Title="工程1"
ExeName32="工程1.exe"
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=2
FavorPentiumPro(tm)=0
CodeViewDebugInfo=-1
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0

FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1