VB函数指针的问题
在网上搜了一篇文章:http://blog. 代码如下
'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
本文来自CSDN博客，转载请标明出处：http://blog.
-------------------------------------------------
查了下 VB中的声明
Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal wType As Long) As Long
对于这一句的调用不是很明白
Set MessageBoxW = mbw.Create(pMessageBoxW, vbLong, vbLong, vbString, vbString, vbLong)
不知道谁能帮忙解释下 谢谢了
