利用動態創建自動化接口實現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