利用动态创建自动化接口实现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:WINDOWSSYSTEM
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