Changeset 192 for Include/com/vbobject.ab

Timestamp:

Mar 28, 2007, 10:29:58 AM (18 years ago)

Author:

イグトランス (egtra)

Message:

Currencyを追加、その他修正

File:

• Include/com/vbobject.ab (modified) (12 diffs)

Include/com/vbobject.ab

@@ -12 +12 @@
     End Sub
 
-    Sub VBObject(className As String)
-        VBObject(ToWCStr(className))
-    End Sub
-
-    Sub VBObject(className As PCWSTR)
+    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)
-        Dim hr2 = CoCreateInstance(clsid, 0, CLSCTX_ALL, IID_IDispatch, pdisp)
+        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
 
@@ -53 +61 @@
 
     Function Equals(y As VBObject) As Boolean
-        Dim punkX = GetUnknown()
-        Dim punkY = y.GetUnknown()
-        Equals = (punkX == punkY)
-        punkX->Release()
-        punkY->Release()
+        Return _System_COMReferenceEquals(pdisp, y.pdisp)
     End Function
 /*
     Override Function GetHashCode() As Long
-        Dim punk = GetUnknown()
+        Dim punk = _System_GetUnknown(pdisp)
         GetHashCode = _System_HashFromPtr(punk)
         punk->Release()
@@ -79 +83 @@
     End Sub
 
-    Function GetDispatch() As *IDispatch
+    Function Copy() As *IDispatch
         VBObject.Copy(GetDispatch, pdisp)
     End Function
@@ -88 +92 @@
     End Sub
 
-    Sub Detach()
+    Function Detach() As *IDispatch
         VBObject.Move(Detach, pdisp)
-    End Sub
+    End Function
+
+    Function Dispatch() As *IDispatch
+        Dispatch = pdisp
+    End Function
 Private
     Function GetCaller(name As PCWSTR) As DispatchCaller
@@ -96 +104 @@
         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
 
@@ -170 +172 @@
 
     Sub Prop(ByRef arg As VARIANT)
-        Dim dispParams As DISPPARAMS
-        With dispParams
-            .rgvarg = VarPtr(arg)
-            .rgdispidNamedArgs = 0
-            .cArgs = 1
-            .cNamedArgs = 1
-        End With
-        Dim ret As VARIANT
-        Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYPUT, dispParams, ret, ByVal 0, 0)
-        Dispose()
+        setProp(arg, DISPATCH_PROPERTYPUT)
     End Sub
 
@@ -187 +180 @@
 
     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()
+        setProp(arg, DISPATCH_PROPERTYPUTREF)
     End Sub
 
@@ -228 +212 @@
     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)
@@ -244 +266 @@
     Return New VBObject(ToWCStr(className))
 End Function
-
+/*
 #ifdef _WIN32_DCOM
 Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
@@ -250 +272 @@
     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
+    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)
@@ -270 +292 @@
         Return Nothing
     End If
-End Function    
+End Function
 
 Function CreateObject(className As String, serverName As String) As VBObject
@@ -279 +301 @@
 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
+        ' 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