source: Include/com/vbobject.ab@ 192

' com/vbobject.ab

#ifndef _COM_VBIBJECT_AB
#define _COM_VBIBJECT_AB

#include <com/variant.ab>

Class VBObject
Public
    Sub VBObject()
        pdisp = 0
    End Sub

    Sub VBObject(className As String, pOuter As *IUnknown, clsContext As DWord)
        VBObject(ToWCStr(className), pOuter, clsContext)
    End Sub

    Sub VBObject(className As PCSTR, pOuter As *IUnknown, clsContext As DWord)
        VBObject(ToWCStr(className), pOuter, clsContext)
    End Sub

    Sub VBObject(className As PCWSTR, pOuter As *IUnknown, clsContext As DWord)
        pdisp = 0
        Dim clsid As CLSID
        Dim hr = _System_CLSIDFromString(className, clsid)
        VBObject(clsid, pOuter, clsContext)
    End Sub

    Sub VBObject(ByRef clsid As CLSID, pOuter As *IUnknown, clsContext As DWord)
        Dim hr = CoCreateInstance(clsid, pOuter, clsContext, IID_IDispatch, pdisp)
    End Sub

    Sub VBObject(ByRef obj As VBObject)
        pdisp = obj.pdisp
        pdisp->AddRef()
    End Sub

    Sub Operator =(ByRef obj As VBObject)
        ~VBObject()
        VBObject(obj)
    End Sub

    Sub ~VBObject()
        Clear()
    End Sub

    Sub Clear()
        If pdisp <> 0 Then
            pdisp->Release()
            pdisp = 0
        End If
    End Sub

    Function Operator [](name As PCWSTR) As DispatchCaller
        Return GetCaller(name)
    End Function

    Function Operator [](name As String) As DispatchCaller
        Return GetCaller(ToWCStr(name))
    End Function

    Function Equals(y As VBObject) As Boolean
        Return _System_COMReferenceEquals(pdisp, y.pdisp)
    End Function
/*
    Override Function GetHashCode() As Long
        Dim punk = _System_GetUnknown(pdisp)
        GetHashCode = _System_HashFromPtr(punk)
        punk->Release()
    End Function
*/
    Function Operator ==(y As VBObject) As Boolean
        Return Equals(y)
    End Function

    Function Operator <>(y As VBObject) As Boolean
        Return Not Equals(y)
    End Function

    Sub Assign(p As *IDispatch)
        Clear()
        VBObject.Copy(pdisp, p)
    End Sub

    Function Copy() As *IDispatch
        VBObject.Copy(GetDispatch, pdisp)
    End Function

    Sub Attach(ByRef p As *IDispatch)
        Clear()
        VBObject.Move(pdisp, p)
    End Sub

    Function Detach() As *IDispatch
        VBObject.Move(Detach, pdisp)
    End Function

    Function Dispatch() As *IDispatch
        Dispatch = pdisp
    End Function
Private
    Function GetCaller(name As PCWSTR) As DispatchCaller
        Dim dispid As DISPID
        Dim hr = pdisp->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
        Return New DispatchCaller(pdisp, dispid)
    End Function

    pdisp As *IDispatch

    Static Sub Copy(ByRef dst As *IDispatch, ByVal src As *IDispatch)
        dst = src
        dst->AddRef()
    End Sub

    Static Sub Move(ByRef dst As *IDispatch, ByRef src As *IDispatch)
        dst = src
        src = 0
    End Sub
End Class

Class DispatchCaller
Public
    Sub DispatchCaller()
    End Sub
    Sub DispatchCaller(pDispatch As *IDispatch, dispatchId As DISPID)
        pdisp = pDispatch
        pdisp->AddRef()
        dispid = dispatchId
    End Sub

    Sub DispatchCaller(ByRef dc As DispatchCaller)
        pdisp = dc.pdisp
        pdisp->AddRef()
        dispid = dc.dispid
    End Sub

    Sub Operator =(ByRef dc As DispatchCaller)
        Dispose()
        DispatchCaller(dc)
    End Sub

    Sub Dispose()
        If pdisp <> 0 Then
            pdisp->Release()
            pdisp = 0
        End If
    End Sub

    Sub ~DispatchCaller()
        Dispose()
    End Sub

    Function Prop() As Variant
        Dim dispParams As DISPPARAMS
        With dispParams
            .rgvarg = 0
            .rgdispidNamedArgs = 0
            .cArgs = 0
            .cNamedArgs = 0
        End With
        Dim ret As VARIANT
        Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ret, 0, 0)
        Dispose()
        Dim v = New Variant
        v.Attach(ret)
        Return v
    End Function

    Sub Prop(ByRef arg As Variant)
        Prop(ByVal arg.PtrToVariant)
    End Sub

    Sub Prop(ByRef arg As VARIANT)
        setProp(arg, DISPATCH_PROPERTYPUT)
    End Sub

    Sub PropRef(ByRef arg As Variant)
        PropRef(arg.PtrToVariant)
    End Sub

    Sub PropRef(ByRef arg As VARIANT)
        setProp(arg, DISPATCH_PROPERTYPUTREF)
    End Sub

    Function Call(cArgs As Long, args As *VARIANT) As Variant
        Dim dispParams As DISPPARAMS
        With dispParams
            .rgvarg = args
            .rgdispidNamedArgs = 0
            .cArgs = cArgs
            .cNamedArgs = 0
        End With
        Dim ret As VARIANT
        Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
        Dispose()
        Dim v = New Variant
        v.Attach(ret)
        Return v
    End Function

'   Function Call(cArgs As Long, args As *Variant) As Variant
'   End Function

    Function Call() As Variant
        Return Call(0, 0)
    End Function

    Function Call(arg1 As Variant) As Variant
        Return Call(1, arg1.PtrToVariant)
    End Function

    Function Call(ByRef arg1 As Variant, ByRef arg2 As Variant) As Variant
        Dim arg[1] As VARIANT

        Return Call(2, VarPtr(arg1) As *VARIANT)
    End Function

Private
    Sub setProp(ByRef arg As VARIANT, callType As Word)
        Dim dispidNamed = DISPID_PROPERTYPUT As DISPID
        Dim dispParams As DISPPARAMS
        With dispParams
            .rgvarg = VarPtr(arg)
            .rgdispidNamedArgs = VarPtr(dispidNamed)
            .cArgs = 1
            .cNamedArgs = 1
        End With
        Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
        Dispose()
    End Sub


    pdisp As *IDispatch
    dispid As DISPID
End Class

Function CallByName(obj As VBObject, procName As String, callType As Word, cArgs As Long, args As *VARIANT) As Variant
    Return CallByName(obj.Dispatch, ToWCStr(procName), callType, cArgs, args)
End Function

Function CallByName(obj As VBObject, procName As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
    Return CallByName(obj.Dispatch, procName, callType, cArgs, args)
End Function

Function CallByName(obj As *IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
    Dim dispid As DISPID
    Dim hr = obj->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
    Dim dispParams As DISPPARAMS
    With dispParams
        .rgvarg = args
        .rgdispidNamedArgs = 0
        .cArgs = cArgs
        .cNamedArgs = 0
    End With
    Dim ret As VARIANT
    hr = obj->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
    CallByName.Attach(ret)
    Return CallByName
End Function

Function CreateObject(className As PCWSTR) As VBObject
    Return New VBObject(className)
End Function

Function CreateObject(className As String) As VBObject
    Return New VBObject(ToWCStr(className))
End Function
/*
#ifdef _WIN32_DCOM
Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
    Dim clsid As CLSID
    Dim si As COSERVERINFO
    Dim context As DWord
    If /*Server = 0 OrElse* / Server[0] = 0 Then
        context = CLSCTX_SERVER
    Else
        context = CLSCTX_REMOTE_SERVER
        si.pwszName = serverName
    End If

    Dim hr = _System_CLSIDFromString(className, clsid)

    Dim mqi As MULTI_QI
    mqi.pIID = VarPtr(IID_IUnknown)
    hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
    If SUCCEEDED(hr) Then
        Dim obj As VBObject
        obj.Attach(mqi.pItf As IDispatch)
        Return obj
    Else
        'Throw
        Return Nothing
    End If
End Function

Function CreateObject(className As String, serverName As String) As VBObject
    Return CreateObject(ToWCStr(className), ToWCStr(serverName))
End Function
#endif
*/
Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT
    If pwString[0] = &h007b As WCHAR Then
        ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
        _System_CLSIDFromString = CLSIDFromString(pwString, guid)
    Else
        _System_CLSIDFromString = CLSIDFromProgID(pwString, guid)
    End If
End Function

Function _System_COMReferenceEquals(p As *IUnknown, q As *IUnknown) As Boolean
    If p = q Then
        Return True
    Else If p = 0 Or q = 0 Then
        Return False
    End If

    Dim punkX = _System_GetUnknown(p)
    Dim punkY = _System_GetUnknown(q)
    If punkX = punkY Then
        _System_COMReferenceEquals = True
    Else
        _System_COMReferenceEquals = False
    End If
    punkX->Release()
    punkY->Release()
End Function

Function _System_GetUnknown(p As *IUnknown) As *IUnknown 'pは任意のCOMインタフェース
    If FAILDED(pdisp->QueryInterface(IID_Unknown, _System_GetUnknown)) Then
        GetUnknown = 0
    End If
End Function

#endif '_COM_VBIBJECT_AB