source: Include/com/vbobject.ab@ 175

' 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)
        VBObject(ToWCStr(className))
    End Sub

    Sub VBObject(className As PCWSTR)
        pdisp = 0
        Dim clsid As CLSID
        Dim hr = _System_CLSIDFromString(className, clsid)
        Dim hr2 = CoCreateInstance(clsid, 0, CLSCTX_ALL, 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
        Dim punkX = GetUnknown()
        Dim punkY = y.GetUnknown()
        Equals = (punkX == punkY)
        punkX->Release()
        punkY->Release()
    End Function
/*
    Override Function GetHashCode() As Long
        Dim punk = GetUnknown()
        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 GetDispatch() As *IDispatch
        VBObject.Copy(GetDispatch, pdisp)
    End Function

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

    Sub Detach() As *IDispatch
        VBObject.Move(Detach, pdisp)
    End Sub
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

    Function GetUnknown() As *IUnknown
        If FAILDED(pdisp->QueryInterface(IID_Unknown, GetUnknown)) Then
            GetUnknown = 0
        End If
    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)
        Dim dispParams As DISPPARAMS
        With dispParams
            .rgvarg = 1
            .rgdispidNamedArgs = 0
            .cArgs = VarPtr(arg)
            .cNamedArgs = 0
        End With
        Dim ret As VARIANT
        Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYPUT, dispParams, ret, ByVal 0, 0)
        Dispose()
    End Sub

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

    Sub PropRef(ByRef arg As VARIANT)
        Dim dispParams As DISPPARAMS
        With dispParams
            .rgvarg = 1
            .rgdispidNamedArgs = 0
            .cArgs = VarPtr(arg)
            .cNamedArgs = 0
        End With
        Dim ret As VARIANT
        Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYPUTREF, dispParams, ret, ByVal 0, 0)
        Dispose()
    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
    pdisp As *IDispatch
    dispid As DISPID
End Class
/*
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

#endif '_COM_VBIBJECT_AB