' com/variant.ab #ifndef _COM_VARIANT_AB #define _COM_VARIANT_AB #require #require #require Class Variant Public Sub Variant() VariantInit(v) End Sub Sub Variant(y As Variant) VariantInit(v) VariantCopy(v, y.v) End Sub Sub Variant(ByRef y As VARIANT) VariantInit(v) VariantCopy(v, y) End Sub Sub Variant(n As SByte) v.vt = VT_I1 SetByte(VarPtr(v.val), n) End Sub Sub Variant(n As Byte) v.vt = VT_UI1 SetByte(VarPtr(v.val), n) End Sub Sub Variant(n As Integer) v.vt = VT_I2 SetWord(VarPtr(v.val), n) End Sub Sub Variant(n As Word) v.vt = VT_UI2 SetWord(VarPtr(v.val), n) End Sub Sub Variant(n As Long) v.vt = VT_I4 SetDWord(VarPtr(v.val), n) End Sub Sub Variant(n As DWord) v.vt = VT_UI4 SetDWord(VarPtr(v.val), n) End Sub Sub Variant(n As Int64) v.vt = VT_I8 SetQWord(VarPtr(v.val), n) End Sub Sub Variant(n As QWord) v.vt = VT_UI8 SetQWord(VarPtr(v.val), n) End Sub Sub Variant(n As Single) v.vt = VT_R4 SetSingle(VarPtr(v.val), n) End Sub Sub Variant(n As Double) v.vt = VT_R8 SetDouble(VarPtr(v.val), n) End Sub Sub Variant(bs As BString) v.vt = VT_BSTR SetPointer(VarPtr(v.val), SysAllocStringLen(bs.BStr, bs.Length)) End Sub Sub Variant(p As *IUnknown) p->AddRef() v.vt = VT_UNKNOWN SetPointer(VarPtr(v.val), p) End Sub Sub Variant(p As *IDispatch) p->AddRef() v.vt = VT_DISPATCH SetPointer(VarPtr(v.val), p) End Sub /* Sub Variant(b As VARIANT_BOOL) v.vt = VT_BOOL SetWord(VarPtr(v.val), b) End Sub */ Sub Variant(b As Boolean) v.vt = VT_BOOL If b Then SetWord(VarPtr(v.val), VARIANT_TRUE) Else SetWord(VarPtr(v.val), VARIANT_FALSE) End If End Sub Sub Variant(s As String) Dim bs As BString(s) Variant(bs) End Sub Sub Variant(n As Currency) v.vt = VT_CY SetQWord(VarPtr(v.val), n.Cy As QWord) End Sub Sub ~Variant() Clear() End Sub Sub Clear() VariantClear(v) v.vt = VT_EMPTY End Sub Sub Operator =(y As Variant) Assign(y.v) End Sub Sub Operator =(y As VARIANT) Assign(y) End Sub Sub Assign(from As Variant) Assign(from.v) End Sub Sub Assign(ByRef from As VARIANT) Variant.Copy(v, from) End Sub Sub AssignInd(ByRef from As VARIANT) VariantCopyInd(v, from) End Sub Sub Attach(ByRef from As VARIANT) Variant.Move(v, from) End Sub Const Function Copy() As VARIANT Variant.Copy(Copy, v) End Function Function Detach() As VARIANT Variant.Move(Detach, v) End Function /* Static Function Assgin(ByRef from As VARIANT) As Variant Assign = New Variant Assgin.Assign(from) End Function Static Function Attach(ByRef from As VARIANT) As Variant Attach = New Variant Attach.Attach(from) End Function */ 'Operators Const Function Operator ^(y As Variant) As Variant Dim ret = New Variant VarPow(This.v, y.v, ret.v) Return ret End Function Const Function Operator +() As Variant Return New Variant(This) End Function Const Function Operator -() As Variant Dim ret = New Variant VarNeg(This.v, ret.v) Return ret End Function Const Function Operator *(y As Variant) As Variant Dim ret = New Variant VarMul(This.v, y.v, ret.v) Return ret End Function Const Function Operator /(y As Variant) As Variant Dim ret = New Variant VarDiv(This.v, y.v, ret.v) Return ret End Function Const Function Operator \(y As Variant) As Variant Dim ret = New Variant VarIDiv(This.v, y.v, ret.v) Return ret End Function Const Function Operator Mod(y As Variant) As Variant Dim ret = New Variant VarMod(This.v, y.v, ret.v) Return ret End Function Const Function Operator +(y As Variant) As Variant Dim ret = New Variant VarAdd(This.v, y.v, ret.v) Return ret End Function Const Function Operator -(y As Variant) As Variant Dim ret = New Variant VarSub(This.v, y.v, ret.v) Return ret End Function Const Function Operator &(y As Variant) As Variant Dim ret = New Variant VarCat(This.v, y.v, ret.v) Return ret End Function Const Function Operator And(y As Variant) As Variant Dim ret = New Variant VarAnd(This.v, y.v, ret.v) Return ret End Function Const Function Operator Or(y As Variant) As Variant Dim ret = New Variant VarOr(This.v, y.v, ret.v) Return ret End Function Const Function Operator Xor(y As Variant) As Variant Dim ret = New Variant VarXor(This.v, y.v, ret.v) Return ret End Function Const Function Operator Not() As Variant Dim ret = New Variant VarNot(This.v, ret.v) Return ret End Function Static Function Imp(x As Variant, y As Variant) As Variant Dim ret = New Variant VarImp(x.v, y.v, ret.v) Return ret End Function Static Function Eqv(x As Variant, y As Variant) As Variant Dim ret = New Variant VarEqv(x.v, y.v, ret.v) Return ret End Function Const Function Abs() As Variant Dim ret = New Variant VarAbs(This.v, ret.v) Return ret End Function Const Function Fix() As Variant Dim ret = New Variant VarFix(This.v, ret.v) Return ret End Function Const Function Int() As Variant Dim ret = New Variant VarInt(This.v, ret.v) Return ret End Function Const Function Round(cDecimals As Long) As Variant Dim ret = New Variant VarRound(This.v, cDecimals, ret) Return ret End Function Const Function Round() As Variant Return Round(0) End Function Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT Return VarCmp(x.v, y.v, lcid, flags) End Function Static Function Compare(x As Variant, y As Variant) As HRESULT Return VarCmp(x.v, y.v, LOCALE_USER_DEFAULT, 0) 'VARCMP_NULL = 3を返す場合があるので注意 End Function Const Function Operator ==(y As Variant) As Boolean 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 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 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 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 c = Compare(This, y) If result = VARCMP_GT Or result = VARCMP_EQ Then Return True Else Return False End If End Function Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant Dim ret = New Variant ChangeType(ret, flags, vt) Return ret End Function Const Function ChangeType(vt As VARTYPE) As Variant Return ChangeType(vt, 0) End Function Const Function ChangeType(ByRef ret As VARIANT, flags As Word, vt As VARTYPE) As HRESULT Return VariantChangeType(ret, v, flags, vt) End Function Const Function ChangeType(ByRef ret As Variant, flags As Word, vt As VARTYPE) As HRESULT Return ChangeType(ret.v, flags, vt) End Function Const Function VarType() As VARTYPE Return v.vt End Function Override Function ToString() As String Dim tmp = ChangeType(VT_BSTR) Dim bs = ((tmp.v.val As ULONG_PTR) As BSTR) Return New String(bs As PCWSTR, SysStringLen(bs) As Long) End Function Override Function GetHashCode() As Long Dim p = (VarPtr(v) As *DWord) Return (p[0] Xor p[1] Xor p[2] Xor p[3]) As Long End Function Const Function ValUI1() As Byte Dim r = ChangeType(VT_UI1) Return GetByte(VarPtr(r.val)) End Function Sub ValUI1(x As Byte) Clear() SetByte(VarPtr(v.val), x) v.vt = VT_UI1 End Sub Const Function ValUI2() As Word Dim r = ChangeType(VT_UI2) Return GetWord(VarPtr(r.val)) End Function Sub ValUI2(x As Word) Clear() SetWord(VarPtr(v.val), x) v.vt = VT_UI2 End Sub Const Function ValUI4() As DWord Dim r = ChangeType(VT_UI4) Return GetDWord(VarPtr(r.val)) End Function Sub ValUI4(x As DWord) Clear() SetDWord(VarPtr(v.val), x) v.vt = VT_UI4 End Sub Const Function ValUI8() As QWord Dim r = ChangeType(VT_UI8) Return GetQWord(VarPtr(r.val)) End Function Sub ValUI8(x As QWord) Clear() SetQWord(VarPtr(v.val), x) v.vt = VT_UI8 End Sub Const Function ValI1() As SByte Dim r = ChangeType(VT_I1) Return GetByte(VarPtr(r.val)) As SByte End Function Sub ValI1(x As SByte) Clear() SetByte(VarPtr(v.val), x As Byte) v.vt = VT_I1 End Sub Const Function ValI2() As Integer Dim r = ChangeType(VT_I2) Return GetWord(VarPtr(r.val)) As Integer End Function Sub ValI2(x As Integer) Clear() SetWord(VarPtr(v.val), x As Word) v.vt = VT_I2 End Sub Const Function ValI4() As Long Dim r = ChangeType(VT_I4) Return GetDWord(VarPtr(r.val)) As Long End Function Sub ValI4(x As Long) Clear() SetDWord(VarPtr(v.val), x As DWord) v.vt = VT_I4 End Sub Const Function ValI8() As Int64 Dim r = ChangeType(VT_I8) Return GetQWord(VarPtr(r.val)) As Int64 End Function Sub ValI8(x As Int64) Clear() SetQWord(VarPtr(v.val), x As QWord) v.vt = VT_I8 End Sub Const Function ValR4() As Single Dim r = ChangeType(VT_R4) Return GetSingle(VarPtr(r.val)) End Function Sub ValR4(x As Single) Clear() SetDWord(VarPtr(v.val), x) v.vt = VT_R4 End Sub Const Function ValR8() As Double Dim r = ChangeType(VT_UI8) Return GetDouble(VarPtr(r.val)) End Function Sub ValR8(x As Double) Clear() SetDouble(VarPtr(v.val), x) v.vt = VT_R8 End Sub Const Function ValBool() As VARIANT_BOOL Dim r = ChangeType(VT_BOOL) Return GetWord(VarPtr(r.val)) End Function Sub ValBool(x As VARIANT_BOOL) Clear() SetWord(VarPtr(v.val), x) v.vt = VT_BOOL End Sub Const Function ValError() As SCODE Dim r = ChangeType(VT_ERROR) Return GetDWord(VarPtr(r.val)) End Function Sub ValError(x As SCODE) Clear() SetDWord(VarPtr(v.val), x) v.vt = VT_ERROR End Sub Const Function ValCy() As Currency End Function Sub ValCy(x As Currency) End Sub 'ValDate Const Function ValStr() As BString Dim r As VARIANT ChangeType(r, 0, VT_BSTR) Dim bs = New BString bs.Attach(GetPointer(VarPtr(r.val)) As BSTR) Return bs End Function Sub ValStr(x As BString) Clear() v.vt = VT_BSTR SetPointer(VarPtr(v.val), x.Copy()) End Sub Const Function ValUnknown() As *IUnknown Dim r As VARIANT ChangeType(r, 0, VT_UNKNOWN) Return GetPointer(VarPtr(r.val)) As *IUnknown End Function Sub ValUnknown(x As *IUnknown) Clear() SetPointer(VarPtr(v.val), x.Copy()) x->AddRef() v.vt = VT_UNKNOWN End Sub Const Function ValObject() As VBObject Dim r As VARIANT ChangeType(r, 0, VT_DISPATCH) Dim o As VBObject o.Attach(GetPointer(VarPtr(r.val)) As *IDispatch) Return o End Function Sub ValObject(x As VBObject) Clear() SetPointer(VarPtr(v.val), x.Copy()) x->AddRef() v.vt = VT_DISPATH End Sub 'ValArray 'ValDecimal Function PtrToVariant() As *VARIANT Return VarPtr(v) End Function Static Function OptionalParam() As Variant ' If _System_VariantOptionalParam = Nothing Then ' 'ToDo マルチスレッド対応 _System_VariantOptionalParam = New Variant _System_VariantOptionalParam.ValError = DISP_E_PARAMNOTFOUND ' End If Return _System_VariantOptionalParam End Function Private v As VARIANT Static Sub Copy(ByRef dst As VARIANT, ByRef src As VARIANT) VariantCopy(dst, src) End Sub Static Sub Move(ByRef dst As VARIANT, ByRef src As VARIANT) dst = src ' src.vt = VT_EMPTY End Sub End Class 'Dim _System_VariantOptionalParam = Nothing As Variant /* Function Abs(v As Variant) As Variant Return v.Abs() End Function Function Fix(v As Variant) As Variant Return v.Fix() End Function Function Int(v As Variant) As Variant Return v.Int() End Function Function VarType(v As Variant) As VARTYPE Return v.VarType() End Function */ #endif '_COM_VARIANT_AB