source: trunk/Include/com/variant.ab@ 497

' com/variant.ab

'#require <com/index.ab>

Namespace ActiveBasic
Namespace COM

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), bs.Copy))
    End Sub

    Sub Variant(unk As IUnknown)
        If Not IsNothing(unk) Then unk.AddRef()
        v.vt = VT_UNKNOWN
        SetPointer(VarPtr(v.val), ObjPtr(unk))
    End Sub

    Sub Variant(disp As IDispatch)
        If Not IsNothing(disp) Then disp.AddRef()
        v.vt = VT_DISPATCH
        SetPointer(VarPtr(v.val), ObjPtr(disp))
    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)
        ValStr = New BString(s)
    End Sub

    Sub Variant(n As Currency)
        v.vt = VT_CY
        SetQWord(VarPtr(v.val), n.Cy As QWord)
    End Sub

    Sub Variant(n As Decimal)
        Dim p = VarPtr(v) As *DECIMAL
        p[0] = n.Dec
        v.vt = VT_DECIMAL
    End Sub


    Sub ~Variant()
        Clear()
    End Sub

    Sub Clear()
        VariantClear(v)
        v.vt = VT_EMPTY
    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
        Abs = New Variant
        VarAbs(This.v, Abs.v)
    End Function

    Const Function Fix() As Variant
        Fix = New Variant
        VarFix(This.v, Fix.v)
    End Function

    Const Function Int() As Variant
        Int = New Variant
        VarInt(This.v, Int.v)
    End Function

    Const Function Round(cDecimals = 0 As Long) As Variant
        Round = New Variant
        VarRound(This.v, cDecimals, Round.v)
    End Function

    Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT
        Return VarCmp(removeNull(x).v, removeNull(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)
        Return c = VARCMP_EQ
    End Function

    Const Function Operator <>(y As Variant) As Boolean
        Dim c = Compare(This, y)
        Return c <> VARCMP_EQ
    End Function

    Const Function Operator <(y As Variant) As Boolean
        Dim c = Compare(This, y)
        Return c = VARCMP_LT
    End Function

    Const Function Operator >(y As Variant) As Boolean
        Dim c = Compare(This, y)
        Return c = VARCMP_GT
    End Function

    Const Function Operator <=(y As Variant) As Boolean
        Dim c = Compare(This, y)
        Return c = VARCMP_LT Or c = VARCMP_EQ
    End Function

    Const Function Operator >=(y As Variant) As Boolean
        Dim c = Compare(This, y)
        Return c = VARCMP_GT Or c = VARCMP_EQ
    End Function

    Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant
        ChangeType = New Variant
        ChangeType(ChangeType, flags, vt)
    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
        /*Using*/ Dim bs = ValStr
        ToString = bs.ToString
        bstr.Dispose() 'End Using
    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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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
        Dim r = ChangeType(VT_CY)
        ValCy = New Currency
        ValCy.Cy = GetQWord(VarPtr(r.v.val))
    End Function

    Sub ValCy(x As Currency)
        Clear()
        SetQWord(VarPtr(v.val), x.Cy)
        v.vt = VT_CY
    End Sub
    
    'ValDate

    Const Function ValStr() As BString
        ValStr = New BString
        Dim r As VARIANT
        ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR)
        ValStr.Attach(GetPointer(VarPtr(r.val)) As BSTR)
    End Function

    Sub ValStr(x As BString)
        Clear()
        v.vt = VT_BSTR
        If IsNothing(x) Then
            SetPointer(VarPtr(v.val), SysAllocStringLen(0))
        Else
            SetPointer(VarPtr(v.val), x.Copy())
        End If
    End Sub

    Const Function ValUnknown() As IUnknown
        Dim r As VARIANT
        ChangeType(r, 0, VT_UNKNOWN)
        Return _System_PtrUnknown(r.val As ULONG_PTR As VoidPtr)
    End Function

    Sub ValUnknown(x As IUnknown)
        Clear()
        SetPointer(VarPtr(v.val), ObjPtr(x))
        If Not IsNothing(x) Then
            x.AddRef()
        End If
        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

    Const Function ValDecimal() As Decimal
        Dim p = VarPtr(v) As *Decimal
        Return New Deciaml(ByVal p)
    End Function

    Sub ValDecimal(x As Decimal)
        Clear()
        Dim p = VarPtr(v) As *DECIMAL
        p[0] = x.Dec
        v.vt = VT_DECIMAL '念の為
    End Sub
    

    Function PtrToVariant() As *VARIANT
        Return VarPtr(v)
    End Function

    Static Function OptionalParam() As Variant
        If IsNothing(optionalParam) Then
            Dim t = New Variant
            t.ValError = DISP_E_PARAMNOTFOUND
            InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0)
        End If
        Return optionalParam
    End Function

    Static Function Null() As Variant
        If IsNothing(optionalParam) Then
            Dim t = New Variant
            Dim p = t.PtrToVariant
            p->vt = VT_NULL
            InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0)
        End If
        Return optionalParam
    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

    Static Function removeNull(v As Variant) As Varinat
        If IsNothing(v) Then
            removeNull = Null
        Else
            removeNull = v
        End If
    End Function

    Static optionalParam = Nothing As Variant
    Static null = Nothing As Variant
End Class

/*
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
*/

End Namespace 'COM
End Namespace 'ActiveBasic