利用動態建立自動化介面實現VB的函式指標呼叫 (轉)

利用動態建立自動化介面實現VB的函式指標呼叫 (轉)[@more@]

發信人: RoachCock (chen3feng), 信區: TRD
標  題: 我的 VB的指標
發信站: BBS 水木清華站 (Fri Jan  3 14:54:25 ), 轉信
 
本文首發於水木清華BBS MicrosoftTRD版，轉載請保留有關資訊
 
作者chen3feng(to:RoachCock@smth.org">RoachCock@smth.org)
: , .com">chen3fengx@hotmail.com
 
 
前幾天在CSDN文件中心見了一篇 Matthew Curland的VB函式指標呼叫，它是用的動態建立自定義介面指標
然後回掉其某個方法,不過這種方法雖然高，但是每一種函式需要建立一個自定義介面
型別，還得使用IDL語言，實在算不上方便，昨天我嘗試出來一種方案，那就是動態建立自
動化介面指標。雖然效率低，但是其靈活性足以彌補這個弱點. 
 
我只動用兩個
為此我用了兩個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的型別對應於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函式,當然，我是先用
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
 
  '呼叫 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,foMessageBoxW", "", 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
  DataBehavior  = 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 PARATA
  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 = Vtr(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: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
CodeViewDeInfo=-1
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0

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