|
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 （编辑：李大同）
【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
|
