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