1  ' com/variant.ab


2 


3  '#require <com/index.ab>


4 


5  Namespace ActiveBasic


6  Namespace COM


7 


8  Class Variant


9  Implements System.IDisposable, System.ICloneable


10  Public


11  Sub Variant()


12  VariantInit(v)


13  End Sub


14 


15  Sub Variant(ByRef y As VARIANT)


16  VariantInit(v)


17  VariantCopy(v, y)


18  End Sub


19 


20  ' 仮


21  Sub Variant(y As Variant)


22  VariantInit(v)


23  VariantCopy(v, y.v)


24  End Sub


25 


26  Sub Variant(n As SByte)


27  v.vt = VT_I1


28  SetByte(VarPtr(v.val), n)


29  End Sub


30 


31  Sub Variant(n As Byte)


32  v.vt = VT_UI1


33  SetByte(VarPtr(v.val), n)


34  End Sub


35 


36  Sub Variant(n As Integer)


37  v.vt = VT_I2


38  SetWord(VarPtr(v.val), n)


39  End Sub


40 


41  Sub Variant(n As Word)


42  v.vt = VT_UI2


43  SetWord(VarPtr(v.val), n)


44  End Sub


45 


46  Sub Variant(n As Long)


47  v.vt = VT_I4


48  SetDWord(VarPtr(v.val), n)


49  End Sub


50 


51  Sub Variant(n As DWord)


52  v.vt = VT_UI4


53  SetDWord(VarPtr(v.val), n)


54  End Sub


55 


56  Sub Variant(n As Int64)


57  v.vt = VT_I8


58  SetQWord(VarPtr(v.val), n)


59  End Sub


60 


61  Sub Variant(n As QWord)


62  v.vt = VT_UI8


63  SetQWord(VarPtr(v.val), n)


64  End Sub


65 


66  Sub Variant(n As Single)


67  v.vt = VT_R4


68  SetSingle(VarPtr(v.val), n)


69  End Sub


70 


71  Sub Variant(n As Double)


72  v.vt = VT_R8


73  SetDouble(VarPtr(v.val), n)


74  End Sub


75 


76  Sub Variant(bs As BString)


77  v.vt = VT_BSTR


78  SetPointer(VarPtr(v.val), bs.Copy())


79  End Sub


80 


81  Sub Variant(unk As IUnknown)


82  If ObjPtr(unk) <> 0 Then unk.AddRef()


83  v.vt = VT_UNKNOWN


84  SetPointer(VarPtr(v.val), ObjPtr(unk))


85  End Sub


86 


87  Sub Variant(disp As IDispatch)


88  If ObjPtr(disp) <> 0 Then disp.AddRef()


89  v.vt = VT_DISPATCH


90  SetPointer(VarPtr(v.val), ObjPtr(disp))


91  End Sub


92  /*


93  Sub Variant(b As VARIANT_BOOL)


94  v.vt = VT_BOOL


95  SetWord(VarPtr(v.val), b)


96  End Sub


97  */


98  Sub Variant(b As Boolean)


99  v.vt = VT_BOOL


100  If b Then


101  SetWord(VarPtr(v.val), VARIANT_TRUE)


102  Else


103  SetWord(VarPtr(v.val), VARIANT_FALSE)


104  End If


105  End Sub


106 


107  Sub Variant(s As String)


108  v.vt = VT_BSTR


109  If IsNothing(s) Then


110  initWithStr(0)


111  Else


112  initWithStr(0)


113  End If


114  End Sub


115 


116  Sub Variant(s As BSTR)


117  initWithStr(s)


118  End Sub


119  Private


120  Sub initWithStr(bs As BSTR)


121  v.vt = VT_BSTR


122  If bs = NULL Then


123  SetPointer(VarPtr(v.val), SysAllocStringLen(0, 0))


124  Else


125  SetPointer(VarPtr(v.val), SysAllocStringByteLen(bs As PCSTR, SysStringByteLen(bs)))


126  End If


127  End Sub


128 


129  Public


130 


131  Sub Variant(n As Currency)


132  v.vt = VT_CY


133  SetQWord(VarPtr(v.val), n.Cy As QWord)


134  End Sub


135 


136  Sub Variant(n As Decimal)


137  Dim p = VarPtr(v) As *DECIMAL


138  p[0] = n.Dec


139  v.vt = VT_DECIMAL


140  End Sub


141 


142  Sub ~Variant()


143  Dispose()


144  End Sub


145 


146  Sub Dispose()


147  VariantClear(v)


148  v.vt = VT_EMPTY


149  End Sub


150 


151  Sub Clear()


152  Dispose()


153  End Sub


154 


155  Virtual Function Clone() As Variant


156  Clone = New Variant(This)


157  End Function


158 


159  Function Copy() As VARIANT


160  Variant.Copy(Copy, v)


161  End Function


162 


163  Function Detach() As VARIANT


164  Variant.Move(Detach, v)


165  End Function


166 


167  Static Function CopyFrom(ByRef from As VARIANT) As Variant


168  CopyFrom = New Variant


169  Variant.Copy(CopyFrom.v, from)


170  End Function


171 


172  Static Function Attach(ByRef from As VARIANT) As Variant


173  Attach = New Variant


174  Variant.Move(Attach.v, from)


175  End Function


176 


177  Static Function CopyIndirectFrom(ByRef from As VARIANT) As Variant


178  CopyIndirectFrom = New Variant


179  VariantCopyInd(CopyIndirectFrom.v, from)


180  End Function


181 


182  'Operators


183  /*


184  Function Operator ^(y As Variant) As Variant


185  Dim ret = New Variant


186  Windows.ThrowIfFailed(VarPow(This.v, y.v, ret.v))


187  Return ret


188  End Function


189  */


190  Function Operator +() As Variant


191  ' Return Clone()


192  End Function


193 


194  Function Operator () As Variant


195  Dim ret = New Variant


196  Windows.ThrowIfFailed(VarNeg(This.v, ret.v))


197  Return ret


198  End Function


199 


200  Function Operator *(y As Variant) As Variant


201  Dim ret = New Variant


202  Windows.ThrowIfFailed(VarMul(This.v, y.v, ret.v))


203  Return ret


204  End Function


205 


206  Function Operator /(y As Variant) As Variant


207  Dim ret = New Variant


208  Windows.ThrowIfFailed(VarDiv(This.v, y.v, ret.v))


209  Return ret


210  End Function


211 


212  Function Operator \(y As Variant) As Variant


213  Dim ret = New Variant


214  Windows.ThrowIfFailed(VarIdiv(This.v, y.v, ret.v))


215  Return ret


216  End Function


217 


218  Function Operator Mod(y As Variant) As Variant


219  Dim ret = New Variant


220  Windows.ThrowIfFailed(VarMod(This.v, y.v, ret.v))


221  Return ret


222  End Function


223 


224  Function Operator +(y As Variant) As Variant


225  Dim ret = New Variant


226  Windows.ThrowIfFailed(VarAdd(This.v, y.v, ret.v))


227  Return ret


228  End Function


229 


230  Function Operator (y As Variant) As Variant


231  Dim ret = New Variant


232  Windows.ThrowIfFailed(VarSub(This.v, y.v, ret.v))


233  Return ret


234  End Function


235 


236  Function Operator &(y As Variant) As Variant


237  Dim ret = New Variant


238  Windows.ThrowIfFailed(VarCat(This.v, y.v, ret.v))


239  Return ret


240  End Function


241 


242  Function Operator And(y As Variant) As Variant


243  Dim ret = New Variant


244  Windows.ThrowIfFailed(VarAnd(This.v, y.v, ret.v))


245  Return ret


246  End Function


247 


248  Function Operator Or(y As Variant) As Variant


249  Dim ret = New Variant


250  Windows.ThrowIfFailed(VarOr(This.v, y.v, ret.v))


251  Return ret


252  End Function


253 


254  Function Operator Xor(y As Variant) As Variant


255  Dim ret = New Variant


256  Windows.ThrowIfFailed(VarXor(This.v, y.v, ret.v))


257  Return ret


258  End Function


259 


260  Function Operator Not() As Variant


261  Dim ret = New Variant


262  Windows.ThrowIfFailed(VarNot(This.v, ret.v))


263  Return ret


264  End Function


265 


266  Static Function Imp(x As Variant, y As Variant) As Variant


267  Dim ret = New Variant


268  Windows.ThrowIfFailed(VarImp(x.v, y.v, ret.v))


269  Return ret


270  End Function


271 


272  Static Function Eqv(x As Variant, y As Variant) As Variant


273  Dim ret = New Variant


274  Windows.ThrowIfFailed(VarEqv(x.v, y.v, ret.v))


275  Return ret


276  End Function


277 


278  Function Abs() As Variant


279  Abs = New Variant


280  Windows.ThrowIfFailed(VarAbs(This.v, Abs.v))


281  End Function


282 


283  Function Fix() As Variant


284  Fix = New Variant


285  Windows.ThrowIfFailed(VarFix(This.v, Fix.v))


286  End Function


287 


288  Function Int() As Variant


289  Int = New Variant


290  Windows.ThrowIfFailed(VarInt(This.v, Int.v))


291  End Function


292 


293  Function Round(cDecimals = 0 As Long) As Variant


294  Round = New Variant


295  Windows.ThrowIfFailed(VarRound(This.v, cDecimals, Round.v))


296  End Function


297 


298  ' ThrowIfFailedを使っていないことに注意


299  Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT


300  Return VarCmp(removeNull(x).v, removeNull(y).v, lcid, flags)


301  End Function


302 


303  Static Function Compare(x As Variant, y As Variant) As HRESULT


304  Return VarCmp(x.v, y.v, LOCALE_USER_DEFAULT, 0) 'VARCMP_NULL = 3を返す場合があるので注意


305  End Function


306 


307  Function Operator ==(y As Variant) As Boolean


308  Dim c = Compare(This, y)


309  Return c = VARCMP_EQ


310  End Function


311 


312  Function Operator <>(y As Variant) As Boolean


313  Dim c = Compare(This, y)


314  Return c <> VARCMP_EQ


315  End Function


316 


317  Function Operator <(y As Variant) As Boolean


318  Dim c = Compare(This, y)


319  Return c = VARCMP_LT


320  End Function


321 


322  Function Operator >(y As Variant) As Boolean


323  Dim c = Compare(This, y)


324  Return c = VARCMP_GT


325  End Function


326 


327  Function Operator <=(y As Variant) As Boolean


328  Dim c = Compare(This, y)


329  Return c = VARCMP_LT Or c = VARCMP_EQ


330  End Function


331 


332  Function Operator >=(y As Variant) As Boolean


333  Dim c = Compare(This, y)


334  Return c = VARCMP_GT Or c = VARCMP_EQ


335  End Function


336 


337  Function ChangeType(vt As VARTYPE, flags = 0 As Word) As Variant


338  ChangeType = New Variant


339  changeType(ChangeType.v, vt, flags)


340  End Function


341  Private


342  Sub changeType(ByRef ret As VARIANT, vt As VARTYPE, flags = 0 As Word)


343  Windows.ThrowIfFailed(VariantChangeType(ret, v, flags, vt))


344  End Sub


345  Public


346 


347  Function VarType() As VARTYPE


348  Return v.vt


349  End Function


350 


351  Override Function ToString() As String


352  Using bs = ValStr


353  ToString = bs.ToString()


354  End Using


355  End Function


356 


357  Override Function GetHashCode() As Long


358  Dim p = (VarPtr(v) As *DWord)


359  Return (p[0] Xor p[1] Xor p[2] Xor p[3]) As Long


360  End Function


361 


362  Function ValUI1() As Byte


363  Dim r = ChangeType(VT_UI1)


364  Return GetByte(VarPtr(r.v.val))


365  End Function


366 


367  Function ValUI2() As Word


368  Dim r = ChangeType(VT_UI2)


369  Return GetWord(VarPtr(r.v.val))


370  End Function


371 


372  Function ValUI4() As DWord


373  Dim r = ChangeType(VT_UI4)


374  Return GetDWord(VarPtr(r.v.val))


375  End Function


376 


377  Function ValUI8() As QWord


378  Dim r = ChangeType(VT_UI8)


379  Return GetQWord(VarPtr(r.v.val))


380  End Function


381 


382  Function ValI1() As SByte


383  Dim r = ChangeType(VT_I1)


384  Return GetByte(VarPtr(r.v.val)) As SByte


385  End Function


386 


387  Function ValI2() As Integer


388  Dim r = ChangeType(VT_I2)


389  Return GetWord(VarPtr(r.v.val)) As Integer


390  End Function


391 


392  Function ValI4() As Long


393  Dim r = ChangeType(VT_I4)


394  Return GetDWord(VarPtr(r.v.val)) As Long


395  End Function


396 


397  Function ValI8() As Int64


398  Dim r = ChangeType(VT_I8)


399  Return GetQWord(VarPtr(r.v.val)) As Int64


400  End Function


401 


402  Function ValR4() As Single


403  Dim r = ChangeType(VT_R4)


404  Return GetSingle(VarPtr(r.v.val))


405  End Function


406 


407  Function ValR8() As Double


408  Dim r = ChangeType(VT_UI8)


409  Return GetDouble(VarPtr(r.v.val))


410  End Function


411 


412  Function ValBool() As VARIANT_BOOL


413  Dim r = ChangeType(VT_BOOL)


414  Return GetWord(VarPtr(r.v.val))


415  End Function


416 


417  Function ValError() As SCODE


418  Dim r = ChangeType(VT_ERROR)


419  Return GetDWord(VarPtr(r.v.val))


420  End Function


421 


422  Function ValCy() As Currency


423  Dim r = ChangeType(VT_CY)


424  ValCy = Currency.FromCy(GetQWord(VarPtr(r.v.val)))


425  End Function


426 


427  'ValDate


428 


429  Function ValStr() As BString


430  ValStr = New BString


431  Dim r As VARIANT


432  changeType(r, VT_BSTR, VARIANT_ALPHABOOL)


433  ValStr.Attach(GetPointer(VarPtr(r.val)) As BSTR)


434  End Function


435 


436  Function ValUnknown() As IUnknown


437  Dim r As VARIANT


438  changeType(r, VT_UNKNOWN)


439  Return _System_PtrUnknown(r.val As ULONG_PTR As VoidPtr)


440  End Function


441 


442  Function ValObject() As VBObject


443  Dim r As VARIANT


444  changeType(r, VT_DISPATCH)


445  ValObject = VBObject.Attach(_System_PtrUnknown(r.val As ULONG_PTR As VoidPtr) As IDispatch)


446  End Function


447 


448  'ValArray


449 


450  Function ValDecimal() As Decimal


451  Dim p = VarPtr(v) As *DECIMAL


452  Return New Decimal(ByVal p)


453  End Function


454 


455  Sub ValDecimal(x As Decimal)


456  Clear()


457  Dim p = VarPtr(v) As *DECIMAL


458  p[0] = x.Dec


459  v.vt = VT_DECIMAL '念の為


460  End Sub


461 


462  Function PtrToVariant() As *VARIANT


463  Return VarPtr(v)


464  End Function


465 


466  Static Function OptionalParam() As Variant


467  If IsNothing(optionalParam) Then


468  Using lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)


469  If IsNothing(optionalParam) Then


470  Dim t = New Variant


471  Dim p = t.PtrToVariant


472  p>vt = VT_ERROR


473  p>val = DISP_E_PARAMNOTFOUND


474  optionalParam = t


475  End If


476  End Using


477  End If


478  Return optionalParam


479  End Function


480 


481  Static Function Null() As Variant


482  If IsNothing(null) Then


483  Using lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)


484  If IsNothing(null) Then


485  Dim t = New Variant


486  Dim p = t.PtrToVariant


487  p>vt = VT_NULL


488  null = t


489  End If


490  End Using


491  End If


492  Return null


493  End Function


494 


495  Private


496  v As VARIANT


497 


498  Static Sub Copy(ByRef dst As VARIANT, ByRef src As VARIANT)


499  VariantCopy(dst, src)


500  End Sub


501 


502  Static Sub Move(ByRef dst As VARIANT, ByRef src As VARIANT)


503  dst = src


504  src.vt = VT_EMPTY


505  End Sub


506 


507  Static Function removeNull(v As Variant) As Variant


508  If IsNothing(v) Then


509  removeNull = Null


510  Else


511  removeNull = v


512  End If


513  End Function


514 


515  Static optionalParam = Nothing As Variant


516  Static null = Nothing As Variant


517 


518  End Class


519 


520 


521  Function Abs(v As Variant) As Variant


522  Return v.Abs()


523  End Function


524 


525  Function Fix(v As Variant) As Variant


526  Return v.Fix()


527  End Function


528 


529  Function Int(v As Variant) As Variant


530  Return v.Int()


531  End Function


532 


533  Function VarType(v As Variant) As VARTYPE


534  Return v.VarType()


535  End Function


536 


537  Namespace Detail


538 


539  Sub CopyFromVariant(ByRef x As Byte, v As Variant)


540  x = v.ValUI1


541  End Sub


542 


543  Sub CopyFromVariant(ByRef x As Word, v As Variant)


544  x = v.ValUI2


545  End Sub


546 


547  Sub CopyFromVariant(ByRef x As DWord, v As Variant)


548  x = v.ValUI4


549  End Sub


550 


551  Sub CopyFromVariant(ByRef x As QWord, v As Variant)


552  x = v.ValUI8


553  End Sub


554 


555  Sub CopyFromVariant(ByRef x As SByte, v As Variant)


556  x = v.ValI1


557  End Sub


558 


559  Sub CopyFromVariant(ByRef x As Integer, v As Variant)


560  x = v.ValI2


561  End Sub


562 


563  Sub CopyFromVariant(ByRef x As Long, v As Variant)


564  x = v.ValI4


565  End Sub


566 


567  Sub CopyFromVariant(ByRef x As Int64, v As Variant)


568  x = v.ValI8


569  End Sub


570 


571  Sub CopyFromVariant(ByRef x As Single, v As Variant)


572  x = v.ValR4


573  End Sub


574 


575  Sub CopyFromVariant(ByRef x As Double, v As Variant)


576  x = v.ValR8


577  End Sub


578 


579  Sub CopyFromVariant(ByRef x As Boolean, v As Variant)


580  x = v.ValBool As Boolean


581  End Sub


582 


583  Sub CopyFromVariant(ByRef x As ActiveBasic.COM.Currency, v As Variant)


584  x = v.ValCy


585  End Sub


586 


587  Sub CopyFromVariant(ByRef x As String, v As Variant)


588  x = v.ValStr.ToString()


589  End Sub


590 


591  Sub CopyFromVariant(ByRef x As ActiveBasic.COM.VBObject, v As Variant)


592  x = v.ValObject


593  End Sub


594 


595  Sub CopyFromVariant(ByRef x As ActiveBasic.COM.Decimal, v As Variant)


596  x = v.ValDecimal


597  End Sub


598 


599  Sub CopyFromVariant(ByRef x As IUnknown, v As Variant)


600  x = v.ValUnknown


601  End Sub


602 


603  Sub CopyFromVariant(ByRef x As Variant, v As Variant)


604  x = v.Clone()


605  End Sub


606 


607  End Namespace


608 


609  End Namespace 'COM


610  End Namespace 'ActiveBasic

