Changeset 192 for Include/com

Timestamp:

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

Author:

イグトランス (egtra)

Message:

Currencyを追加、その他修正

Location:

Include/com

Files:

• bstring.ab (modified) (1 diff)
• currency.ab (added)
• index.ab (modified) (1 diff)
• variant.ab (modified) (16 diffs)
• vbobject.ab (modified) (12 diffs)

Include/com/bstring.ab

@@ -80 +80 @@
     End Sub
 
-    Sub Attach(bstr As BSTR)
+    Sub Attach(ByRef bstr As BSTR)
         Clear()
         BString.Move(bs, bstr)

Include/com/index.ab

@@ -2 +2 @@
 
 #require <com/bstring.ab>
+#require <com/variant.ab>
+#require <com/vbojbect.ab>
+#require <com/currency.ab>

Include/com/variant.ab

@@ -20 +20 @@
     End Sub
 
-    Sub Variant(v As VARIANT)
+    Sub Variant(ByRef y As VARIANT)
         VariantInit(v)
         VariantCopy(v, y)
@@ -132 +132 @@
     End Sub
 
-    Sub Assign(from As VARIANT)
-        Clear()
+    Sub Assign(ByRef from As VARIANT)
         Variant.Copy(v, from)
+    End Sub
+
+    Sub AssignInd(ByRef from As VARIANT)
+        VariantCopyInd(v, from)
     End Sub
 
@@ -141 +144 @@
     End Sub
 
+    Const Function Copy() As VARIANT
+        Variant.Copy(Copy, v)
+    End Function
+
     Function Detach() As VARIANT
         Variant.Move(Detach, v)
@@ -153 +160 @@
     End Function
 
-    Function Operator -() As Variant
+    Const Function Operator +() As Variant
+        Return New Variant(This)
+    End Function
+
+    Const Function Operator -() As Variant
         Dim ret As Variant
         VarNeg(This.v, ret.v)
@@ -219 +230 @@
     End Function
 
-    Function Operator Not() As Variant
+    Const Function Operator Not() As Variant
         Dim ret As Variant
         VarNot(This.v, ret.v)
@@ -237 +248 @@
     End Function
 
-    Function Abs() As Variant
+    Const Function Abs() As Variant
         Dim ret As Variant
         VarAbs(This.v, ret.v)
@@ -243 +254 @@
     End Function
 
-    Function Fix() As Variant
+    Const Function Fix() As Variant
         Dim ret As Variant
         VarFix(This.v, ret.v)
@@ -249 +260 @@
     End Function
 
-    Function Int() As Variant
+    Const Function Int() As Variant
         Dim ret As Variant
         VarInt(This.v, ret.v)
@@ -255 +266 @@
     End Function
 
-    Function Round(cDecimals As Long) As Variant
+    Const Function Round(cDecimals As Long) As Variant
         Dim ret As Variant
         VarRound(This.v, cDecimals, ret)
@@ -261 +272 @@
     End Function
 
-    Function Round() As Variant
+    Const Function Round() As Variant
         Return Round(0)
     End Function
@@ -274 +285 @@
 
     Const Function Operator ==(y As Variant) As Boolean
-        Return Compare(This, y) = VARCMP_EQ
+        Dim c = Compare(This, y)
+        If c = VARCMP_EQ Then
+            Return True
+        Else
+            Return False
+        End If
     End Function
 
     Const Function Operator <>(y As Variant) As Boolean
-        Return Compare(This, y) <> VARCMP_EQ
+        Dim c = Compare(This, y)
+        If c <> VARCMP_EQ Then
+            Return True
+        Else
+            Return False
+        End If
     End Function
 
     Const Function Operator <(y As Variant) As Boolean
-        Return Compare(This, y) = VARCMP_LT
-    End Function
-
-'   Const Function Operator >(y As Variant) As Boolean
-'       Return Compare(This, y) = VARCMP_GT
-'   End Function
-
+        Dim c = Compare(This, y)
+        If c = VARCMP_LT Then
+            Return True
+        Else
+            Return False
+        End If
+    End Function
+/*
+    Const Function Operator >(y As Variant) As Boolean
+        Dim c = Compare(This, y)
+        If c = VARCMP_GT Then
+            Return True
+        Else
+            Return False
+        End If
+    End Function
+*/
     Const Function Operator <=(y As Variant) As Boolean
-        Dim result = Compare(This, y)
-        Return result = VARCMP_LT Or result = VARCMP_EQ
+        Dim c = Compare(This, y)
+        If result = VARCMP_LT Or result = VARCMP_EQ Then
+            Return True
+        Else
+            Return False
+        End If
     End Function
 
     Const Function Operator >=(y As Variant) As Boolean
-        Dim result = Compare(This, y)
-        Return result = VARCMP_GT Or result = VARCMP_EQ
+        Dim c = Compare(This, y)
+        If result = VARCMP_GT Or result = VARCMP_EQ Then
+            Return True
+        Else
+            Return False
+        End If
     End Function
 
@@ -469 +508 @@
     'ValDate
 
-    Const Function ValBStr() As BString
+    Const Function ValStr() As BString
         Dim r As VARIANT
         ChangeType(r, 0, VT_BSTR)
@@ -477 +516 @@
     End Function
 
-    Sub ValBStr(x As BString)
+    Sub ValStr(x As BString)
         Clear()
         v.vt = VT_BSTR
@@ -497 +536 @@
     Const Function ValObject() As VBObject
         Dim r As VARIANT
-        ChangeType(r, 0, VT_DISPATH)
-        Dim o As VBOBject
+        ChangeType(r, 0, VT_DISPATCH)
+        Dim o As VBObject
         o.Attach(GetPointer(VarPtr(r.val)) As *IDispatch)
         Return o
@@ -517 +556 @@
         Return VarPtr(v)
     End Function
+
 Private
     v As VARIANT
@@ -523 +563 @@
         VariantCopy(dst, src)
     End Sub
-        
+
 
     Static Sub Move(ByRef dst As VARIANT, ByRef src As VARIANT)

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