vb module_FunctionPtr 与FunctionPtr共同实现 CallFromDll callbyAddress 可以调用模块的函数/callbyname

Option Explicit

''V0.6 与CallByAddress类似，代码基本一致，就是不知道怎么传ParamArray参数，导致代码重复。
Public Function CallFromDll(ByVal dllName As String,ByVal pFunc As String,ByVal RetType As VariantTypeConstants,ParamArray ParamTypes() As Variant)
Dim hMod
hMod = GetModuleHandle(dllName) '得到库里的模块地址

Dim hFunc As Long
hFunc = GetProcAddress(hMod,pFunc) '得到模块里的函数地址


''值处理
Dim ptype As Variant,ptstr() As Variant,ptChar As String
Dim plng As Integer,pti As Integer
Dim ptVal() As Variant,ptname() As Variant
plng = UBound(ParamTypes)
ReDim ptstr(plng) '类型名
ReDim ptVal(plng) '值列表
ReDim ptname(plng) '变量名列表，因为应用时常数被解释为局部值，无法传递给函数

For Each ptype In ParamTypes
ptstr(pti) = VarType(ptype) 'vbVariant
ptVal(pti) = ptype
If ptstr(pti) = 8 Then ptChar = """" Else ptChar = ""
ptname(pti) = ptChar & ptype & ptChar
'ptname(pti) = "ptVal(" & pti & ")" '会提示类型不匹配，所以用前两句
pti = pti + 1
Next


''执行
Dim func As FunctionPtr
Set func = New FunctionPtr
On Error Resume Next
'MsgBox "CallFromDll=CallByAddress(" & hFunc & "," & RetType & "," & Join(ptname,",") & ")"
scriptRun.Addobject "func",func
scriptRun.AddCode "func.create " & hFunc & "," & Join(ptstr,") & ""
scriptRun.AddCode "func.Object.Invoke " & Join(ptname,") & ""
scriptRun.Reset
CallFromDll = Err.Number
End Function

''v0.6 调用函数 '注意事项：如果是Long类型，参数常数要以&结束。%结束是整型、单精!、双精#、货币@、变长字串$
''返回错误码 （函数地址，返回类型是，参数列表注意使用类型符）
Public Function CallByAddress(ByVal pFunc As Long,ParamArray ParamTypes() As Variant)
Dim ptype As Variant,ptname() As Variant
plng = UBound(ParamTypes)
ReDim ptstr(plng) '类型名
ReDim ptVal(plng) '值列表
ReDim ptname(plng) '变量名列表，因为应用时常数被解释为局部值，无法传递给函数

''以下变量，EbExecuteLine使用时得声明成公有
Dim ptypestr As String,pvalName As String
Dim funO As Object
Dim func As FunctionPtr
Dim funcAdrress As Long,FuncRetType As VariantTypeConstants
'======================

pti = 0
For Each ptype In ParamTypes
ptstr(pti) = VarType(ptype) 'vbVariant
ptVal(pti) = ptype
If ptstr(pti) = 8 Then ptChar = """" Else ptChar = ""
ptname(pti) = ptChar & ptype & ptChar
'ptname(pti) = "ptVal(" & pti & ")" '会提示类型不匹配，所以用前两句
pti = pti + 1
Next
ptypestr = Join(ptstr,") '类型字符串

Set func = New FunctionPtr
funcAdrress = pFunc
FuncRetType = RetType
scriptRun.Addobject "func",func '添加外部对象

On Error Resume Next
scriptRun.AddCode "set funO=func.create(" & funcAdrress & "," & FuncRetType & "," & ptypestr & ")"
'scriptRun.AddCode "set funO=func.create(" & pFunc & "," & vbEmpty & "," & vbString & ")"
'Set funO = func.Create(pFunc,vbEmpty,vbString)

pvalName = Join(ptname,") '值列表字符串
'MsgBox pvalName & ptstr(0) & VarType(ptVal(0)) & "func.Object.Invoke " & pvalName & " "
scriptRun.AddCode "func.Object.Invoke " & pvalName & " "
'func.Object.Invoke "ssssss"
scriptRun.Reset
CallByAddress = Err.Number
End Function

'==============测试函数
Private Sub Test1(ByRef this As Long)
MsgBox "Test1",vbOKOnly,"hehe"
End Sub

Private Sub test(ByVal s As String)
MsgBox s,"hehe"
End Sub

Private Sub test2() Dim p As FunctionPtr Set p = New FunctionPtr Dim d As Object Set d = p.Create(AddressOf test,vbLong,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,vbString,vbLong) 'MessageBoxA 0,"hehe,form MessageBoxA","",0 MessageBoxW.Invoke 0,form MessageBoxW",0End Sub

原文地址：https://www.jb51.cc/vb/264223.html