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 & "," & RetType & "," & 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, ByVal RetType As VariantTypeConstants, ParamArray ParamTypes() As Variant)
    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)      '变量名列表，因为应用时常数被解释为局部值，无法传递给函数
   
   

    ''以下变量，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, vbOKOnly, "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, vbLong, vbLong, vbString, vbString, vbLong)
    'MessageBoxA 0, "hehe,form MessageBoxA", "", 0
    MessageBoxW.Invoke 0, "hehe,form MessageBoxW", "", 0
End Sub