source: trunk/ab5.0/ablib/src/com/vbobject.ab @ 709

' com/vbobject.ab

#require <com/variant.ab>

Namespace ActiveBasic
Namespace COM

Class VBObjectBase
    Implements System.IDisposable, System.IEquatable<VBObjectBase>
Public
    Sub VBObjectBase()
        disp = Nothing
    End Sub

    Sub VBObjectBase(dispObj As IDispatch)
        copy(disp, dispObj)
    End Sub

    Sub ~VBObjectBase()
        Dispose()
    End Sub

    Sub Clear()
        Dispose()
    End Sub

    Virtual Sub Dispose()
        If ObjPtr(disp) <> 0 Then
            disp.Release()
            disp = Nothing
        End If
    End Sub

'   Override Function Equals(y As Object) As Boolean
'   End Function

    Virtual Function Equals(y As VBObjectBase) As Boolean
        Return Detail.COMReferenceEquals(This.Dispatch, y.Dispatch)
    End Function
/*
    Override Function GetHashCode() As Long
        Dim punk = _System_GetUnknown(pdisp)
        GetHashCode = _System_HashFromPtr(punk)
        punk->Release()
    End Function
*/

    Function Copy() As IDispatch
        copy(Copy, disp)
    End Function

    Sub Attach(ByRef y As IDispatch)
'       Clear()
'       move(pdisp, y)
    End Sub

    Function Detach() As IDispatch
        move(Detach, disp)
    End Function

    Function Dispatch() As IDispatch
        Dispatch = disp
    End Function
Protected

    Sub attach(ByRef y As IDispatch)
        Clear()
        move(disp, y)
    End Sub

Private
    disp As IDispatch

    Static Sub copy(ByRef dst As IDispatch, ByVal src As IDispatch)
        dst = src
        If ObjPtr(src) <> 0 Then
            src.AddRef()
        End If
    End Sub

    Static Sub move(ByRef dst As IDispatch, ByRef src As IDispatch)
        dst = src
        src = Nothing
    End Sub

End Class

Class VBObject
    Inherits VBObjectBase
Public
    Static Function Attach(y As IDispatch) As VBObject
        Attach = New VBObject
        Attach.attach(y)
    End Function

    Sub VBObject()
        disp = Nothing
    End Sub

    Sub VBObject(className As String, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord)
        VBObjectBase(createInstance(className, outer, clsContext))
    End Sub

    Sub VBObject(ByRef clsid As CLSID, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord)
        VBObjectBase(createInstance(clsid, outer, clsContext))
    End Sub
Private
    Function createInstance(className As String, outer As IUnknown, clsContext As DWord) As IDispatch
        Dim clsid = Detail.StringToCLSID(ToWCStr(className))
        createInstance = createInstance(clsid, outer, clsContext)
    End Function

    Function createInstance(ByRef clsid As CLSID, outer As IUnknown, clsContext As DWord) As IDispatch
        Dim hr = CoCreateInstance(clsid, ObjPtr(outer), clsContext, IID_IDispatch, createInstance)
        Windows.ThrowIfFailed(hr)
    End Function
Public

    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

Private
    Function GetCaller(name As PCWSTR) As DispatchCaller
        Dim dispid As DISPID
        Dim hr = Dispatch.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
        Windows.ThrowIfFailed(hr)
        Return New DispatchCaller(disp, dispid)
    End Function
End Class

Class DispatchCaller
    Implements System.IDisposable
Public
    Sub DispatchCaller()
    End Sub
    Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID)
        disp = dispObj
        disp.AddRef()
        dispid = dispatchId
    End Sub

    Sub Dispose()
        If ObjPtr(disp) <> NULL Then
            disp.Release()
            disp = Nothing
        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
        Call = New Variant
        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0)
        Windows.ThrowIfFailed(hr)
        Dispose()
    End Function

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

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

    Sub PropRef(arg As Variant)
        PropRef(ByVal 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
        Call = New Variant
        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0)
        Windows.ThrowIfFailed(hr)
        Dispose()
    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(arg0 As Variant) As Variant
        Return Call(1, arg0.PtrToVariant)
    End Function

    Function Call(arg0 As Variant, arg1 As Variant) As Variant
        Dim arg[ELM(2)] As VARIANT
        arg[0] = arg0.Copy()
        arg[1] = arg1.Copy()
        Return Call(2, arg)
    End Function

    Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant) As Variant
        Dim arg[ELM(3)] As VARIANT
        arg[0] = arg0.Copy()
        arg[1] = arg1.Copy()
        arg[2] = arg2.Copy()
        Return Call(3, arg)
    End Function

    Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant, arg3 As Variant) As Variant
        Dim arg[ELM(4)] As VARIANT
        arg[0] = arg0.Copy()
        arg[1] = arg1.Copy()
        arg[2] = arg2.Copy()
        arg[3] = arg3.Copy()
        Return Call(4, arg)
    End Function

/*
    Function Call(arg0 = Variant.OptionalParam As Variant, arg1 = Variant.OptionalParam As Variant,
        arg2 = Variant.OptionalParam As Variant, arg3 = Variant.OptionalParam As Variant,
        arg4 = Variant.OptionalParam As Variant, arg5 = Variant.OptionalParam As Variant,
        arg6 = Variant.OptionalParam As Variant, arg7 = Variant.OptionalParam As Variant,
        arg8 = Variant.OptionalParam As Variant, arg9 = Variant.OptionalParam As Variant) As Variant
        Dim arg[ELM(10)] As VARIANT
        arg[0] = arg0.Copy()
        arg[1] = arg1.Copy()
        arg[2] = arg2.Copy()
        arg[3] = arg3.Copy()
        arg[4] = arg3.Copy()
        arg[5] = arg4.Copy()
        arg[6] = arg5.Copy()
        arg[7] = arg6.Copy()
        arg[8] = arg7.Copy()
        arg[9] = arg8.Copy()
        Return Call(10, arg)
    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 = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
        Windows.ThrowIfFailed(hr)
        Dispose()
    End Sub

    disp 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))
    Windows.ThrowIfFailed(hr)
    Dim dispParams As DISPPARAMS
    With dispParams
        .rgvarg = args
        .rgdispidNamedArgs = 0
        .cArgs = cArgs
        .cNamedArgs = 0
    End With
    CallByName = New Variant
    hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0)
    Windows.ThrowIfFailed(hr)
End Function
/*
Function CreateObject(className As PCWSTR) As VBObject
    Return New VBObject(className, 0, CLSCTX_ALL)
End Function

Function CreateObject(className As String) As VBObject
    Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
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


Namespace Detail
Function StringToCLSID(pwString As PCWSTR) As CLSID
    If pwString[0] = &h007b As WCHAR Then
        ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
        Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID))
    Else
        Windows.ThrowIfFailed(CLSIDFromProgID(pwString, StringToCLSID))
    End If
End Function

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

    Dim punkX = GetUnknown(p)
    Dim punkY = GetUnknown(q)
    If ObjPtr(punkX) = ObjPtr(punkY) Then
        COMReferenceEquals = True
    Else
        COMReferenceEquals = False
    End If
    punkX.Release()
    punkY.Release()
End Function

Function GetUnknown(p As IUnknown) As IUnknown 'pは任意のCOMインタフェース
    If FAILED(p.QueryInterface(IID_IUnknown, GetUnknown)) Then
        GetUnknown = Nothing
    End If
End Function
End Namespace 'Detail

End Namespace 'COM
End Namespace 'ActiveBasic