' com/vbobject.ab

#require <com/variant.ab>

Namespace ActiveBasic
Namespace COM

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 ~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()
		Prop = New Variant
		v.Attach(ret)
		Return v
	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
		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(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 = 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 = New Variant
	CallByName.Attach(ret)
	Return CallByName
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
*/
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

End Namespace 'COM
End Namespace 'ActiveBasic