1  ' com/variant.ab


2 


3  '#require <com/index.ab>


4 


5  Namespace ActiveBasic


6  Namespace COM


7 


8  Class Variant


9  Public


10  Sub Variant()


11  VariantInit(v)


12  End Sub


13 


14  Sub Variant(y As Variant)


15  VariantInit(v)


16  VariantCopy(v, y.v)


17  End Sub


18 


19  Sub Variant(ByRef y As VARIANT)


20  VariantInit(v)


21  VariantCopy(v, y)


22  End Sub


23 


24  Sub Variant(n As SByte)


25  v.vt = VT_I1


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


27  End Sub


28 


29  Sub Variant(n As Byte)


30  v.vt = VT_UI1


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


32  End Sub


33 


34  Sub Variant(n As Integer)


35  v.vt = VT_I2


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


37  End Sub


38 


39  Sub Variant(n As Word)


40  v.vt = VT_UI2


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


42  End Sub


43 


44  Sub Variant(n As Long)


45  v.vt = VT_I4


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


47  End Sub


48 


49  Sub Variant(n As DWord)


50  v.vt = VT_UI4


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


52  End Sub


53 


54  Sub Variant(n As Int64)


55  v.vt = VT_I8


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


57  End Sub


58 


59  Sub Variant(n As QWord)


60  v.vt = VT_UI8


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


62  End Sub


63 


64  Sub Variant(n As Single)


65  v.vt = VT_R4


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


67  End Sub


68 


69  Sub Variant(n As Double)


70  v.vt = VT_R8


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


72  End Sub


73 


74  Sub Variant(bs As BString)


75  v.vt = VT_BSTR


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


77  End Sub


78 


79  Sub Variant(unk As IUnknown)


80  If Not IsNothing(unk) Then unk.AddRef()


81  v.vt = VT_UNKNOWN


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


83  End Sub


84 


85  Sub Variant(disp As IDispatch)


86  If Not IsNothing(disp) Then disp.AddRef()


87  v.vt = VT_DISPATCH


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


89  End Sub


90  /*


91  Sub Variant(b As VARIANT_BOOL)


92  v.vt = VT_BOOL


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


94  End Sub


95  */


96  Sub Variant(b As Boolean)


97  v.vt = VT_BOOL


98  If b Then


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


100  Else


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


102  End If


103  End Sub


104 


105  Sub Variant(s As String)


106  ValStr = New BString(s)


107  End Sub


108 


109  Sub Variant(n As Currency)


110  v.vt = VT_CY


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


112  End Sub


113 


114  Sub Variant(n As Decimal)


115  Dim p = VarPtr(v) As *DECIMAL


116  p[0] = n.Dec


117  v.vt = VT_DECIMAL


118  End Sub


119 


120 


121  Sub ~Variant()


122  Clear()


123  End Sub


124 


125  Sub Clear()


126  VariantClear(v)


127  v.vt = VT_EMPTY


128  End Sub


129 


130  Sub Assign(from As Variant)


131  Assign(from.v)


132  End Sub


133 


134  Sub Assign(ByRef from As VARIANT)


135  Variant.Copy(v, from)


136  End Sub


137 


138  Sub AssignInd(ByRef from As VARIANT)


139  VariantCopyInd(v, from)


140  End Sub


141 


142  Sub Attach(ByRef from As VARIANT)


143  Variant.Move(v, from)


144  End Sub


145 


146  Const Function Copy() As VARIANT


147  Variant.Copy(Copy, v)


148  End Function


149 


150  Function Detach() As VARIANT


151  Variant.Move(Detach, v)


152  End Function


153  /*


154  Static Function Assgin(ByRef from As VARIANT) As Variant


155  Assign = New Variant


156  Assgin.Assign(from)


157  End Function


158 


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


160  Attach = New Variant


161  Attach.Attach(from)


162  End Function


163  */


164  'Operators


165  /*


166  Const Function Operator ^(y As Variant) As Variant


167  Dim ret = New Variant


168  VarPow(This.v, y.v, ret.v)


169  Return ret


170  End Function


171 


172  Const Function Operator +() As Variant


173  Return New Variant(This)


174  End Function


175 


176  Const Function Operator () As Variant


177  Dim ret = New Variant


178  VarNeg(This.v, ret.v)


179  Return ret


180  End Function


181 


182  Const Function Operator *(y As Variant) As Variant


183  Dim ret = New Variant


184  VarMul(This.v, y.v, ret.v)


185  Return ret


186  End Function


187 


188  Const Function Operator /(y As Variant) As Variant


189  Dim ret = New Variant


190  VarDiv(This.v, y.v, ret.v)


191  Return ret


192  End Function


193 


194  Const Function Operator \(y As Variant) As Variant


195  Dim ret = New Variant


196  VarIdiv(This.v, y.v, ret.v)


197  Return ret


198  End Function


199 


200  Const Function Operator Mod(y As Variant) As Variant


201  Dim ret = New Variant


202  VarMod(This.v, y.v, ret.v)


203  Return ret


204  End Function


205 


206  Const Function Operator +(y As Variant) As Variant


207  Dim ret = New Variant


208  VarAdd(This.v, y.v, ret.v)


209  Return ret


210  End Function


211 


212  Const Function Operator (y As Variant) As Variant


213  Dim ret = New Variant


214  VarSub(This.v, y.v, ret.v)


215  Return ret


216  End Function


217 


218  Const Function Operator &(y As Variant) As Variant


219  Dim ret = New Variant


220  VarCat(This.v, y.v, ret.v)


221  Return ret


222  End Function


223 


224  Const Function Operator And(y As Variant) As Variant


225  Dim ret = New Variant


226  VarAnd(This.v, y.v, ret.v)


227  Return ret


228  End Function


229 


230  Const Function Operator Or(y As Variant) As Variant


231  Dim ret = New Variant


232  VarOr(This.v, y.v, ret.v)


233  Return ret


234  End Function


235 


236  Const Function Operator Xor(y As Variant) As Variant


237  Dim ret = New Variant


238  VarXor(This.v, y.v, ret.v)


239  Return ret


240  End Function


241 


242  Const Function Operator Not() As Variant


243  Dim ret = New Variant


244  VarNot(This.v, ret.v)


245  Return ret


246  End Function


247 


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


249  Dim ret = New Variant


250  VarImp(x.v, y.v, ret.v)


251  Return ret


252  End Function


253 


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


255  Dim ret = New Variant


256  VarEqv(x.v, y.v, ret.v)


257  Return ret


258  End Function


259  */


260  Const Function Abs() As Variant


261  Abs = New Variant


262  VarAbs(This.v, Abs.v)


263  End Function


264 


265  Const Function Fix() As Variant


266  Fix = New Variant


267  VarFix(This.v, Fix.v)


268  End Function


269 


270  Const Function Int() As Variant


271  Int = New Variant


272  VarInt(This.v, Int.v)


273  End Function


274 


275  Const Function Round(cDecimals = 0 As Long) As Variant


276  Round = New Variant


277  VarRound(This.v, cDecimals, Round.v)


278  End Function


279 


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


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


282  End Function


283 


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


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


286  End Function


287 


288  Const Function Operator ==(y As Variant) As Boolean


289  Dim c = Compare(This, y)


290  Return c = VARCMP_EQ


291  End Function


292 


293  Const Function Operator <>(y As Variant) As Boolean


294  Dim c = Compare(This, y)


295  Return c <> VARCMP_EQ


296  End Function


297 


298  Const Function Operator <(y As Variant) As Boolean


299  Dim c = Compare(This, y)


300  Return c = VARCMP_LT


301  End Function


302 


303  Const Function Operator >(y As Variant) As Boolean


304  Dim c = Compare(This, y)


305  Return c = VARCMP_GT


306  End Function


307 


308  Const Function Operator <=(y As Variant) As Boolean


309  Dim c = Compare(This, y)


310  Return c = VARCMP_LT Or c = VARCMP_EQ


311  End Function


312 


313  Const Function Operator >=(y As Variant) As Boolean


314  Dim c = Compare(This, y)


315  Return c = VARCMP_GT Or c = VARCMP_EQ


316  End Function


317 


318  Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant


319  ChangeType = New Variant


320  ChangeType(ChangeType, flags, vt)


321  End Function


322 


323  Const Function ChangeType(vt As VARTYPE) As Variant


324  Return ChangeType(vt, 0)


325  End Function


326 


327  Const Function ChangeType(ByRef ret As VARIANT, flags As Word, vt As VARTYPE) As HRESULT


328  Return VariantChangeType(ret, v, flags, vt)


329  End Function


330 


331  Const Function ChangeType(ByRef ret As Variant, flags As Word, vt As VARTYPE) As HRESULT


332  Return ChangeType(ret.v, flags, vt)


333  End Function


334 


335  Const Function VarType() As VARTYPE


336  Return v.vt


337  End Function


338 


339  Override Function ToString() As String


340  /*Using*/ Dim bs = ValStr


341  ToString = bs.ToString


342  bstr.Dispose() 'End Using


343  End Function


344 


345  Override Function GetHashCode() As Long


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


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


348  End Function


349 


350  Const Function ValUI1() As Byte


351  Dim r = ChangeType(VT_UI1)


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


353  End Function


354 


355  Sub ValUI1(x As Byte)


356  Clear()


357  SetByte(VarPtr(v.val), x)


358  v.vt = VT_UI1


359  End Sub


360 


361  Const Function ValUI2() As Word


362  Dim r = ChangeType(VT_UI2)


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


364  End Function


365 


366  Sub ValUI2(x As Word)


367  Clear()


368  SetWord(VarPtr(v.val), x)


369  v.vt = VT_UI2


370  End Sub


371 


372  Const Function ValUI4() As DWord


373  Dim r = ChangeType(VT_UI4)


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


375  End Function


376 


377  Sub ValUI4(x As DWord)


378  Clear()


379  SetDWord(VarPtr(v.val), x)


380  v.vt = VT_UI4


381  End Sub


382 


383  Const Function ValUI8() As QWord


384  Dim r = ChangeType(VT_UI8)


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


386  End Function


387 


388  Sub ValUI8(x As QWord)


389  Clear()


390  SetQWord(VarPtr(v.val), x)


391  v.vt = VT_UI8


392  End Sub


393 


394  Const Function ValI1() As SByte


395  Dim r = ChangeType(VT_I1)


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


397  End Function


398 


399  Sub ValI1(x As SByte)


400  Clear()


401  SetByte(VarPtr(v.val), x As Byte)


402  v.vt = VT_I1


403  End Sub


404 


405  Const Function ValI2() As Integer


406  Dim r = ChangeType(VT_I2)


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


408  End Function


409 


410  Sub ValI2(x As Integer)


411  Clear()


412  SetWord(VarPtr(v.val), x As Word)


413  v.vt = VT_I2


414  End Sub


415 


416  Const Function ValI4() As Long


417  Dim r = ChangeType(VT_I4)


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


419  End Function


420 


421  Sub ValI4(x As Long)


422  Clear()


423  SetDWord(VarPtr(v.val), x As DWord)


424  v.vt = VT_I4


425  End Sub


426 


427  Const Function ValI8() As Int64


428  Dim r = ChangeType(VT_I8)


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


430  End Function


431 


432  Sub ValI8(x As Int64)


433  Clear()


434  SetQWord(VarPtr(v.val), x As QWord)


435  v.vt = VT_I8


436  End Sub


437 


438  Const Function ValR4() As Single


439  Dim r = ChangeType(VT_R4)


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


441  End Function


442 


443  Sub ValR4(x As Single)


444  Clear()


445  SetDWord(VarPtr(v.val), x)


446  v.vt = VT_R4


447  End Sub


448 


449  Const Function ValR8() As Double


450  Dim r = ChangeType(VT_UI8)


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


452  End Function


453 


454  Sub ValR8(x As Double)


455  Clear()


456  SetDouble(VarPtr(v.val), x)


457  v.vt = VT_R8


458  End Sub


459 


460  Const Function ValBool() As VARIANT_BOOL


461  Dim r = ChangeType(VT_BOOL)


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


463  End Function


464 


465  Sub ValBool(x As VARIANT_BOOL)


466  Clear()


467  SetWord(VarPtr(v.val), x)


468  v.vt = VT_BOOL


469  End Sub


470 


471  Const Function ValError() As SCODE


472  Dim r = ChangeType(VT_ERROR)


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


474  End Function


475 


476  Sub ValError(x As SCODE)


477  Clear()


478  SetDWord(VarPtr(v.val), x)


479  v.vt = VT_ERROR


480  End Sub


481 


482  Const Function ValCy() As Currency


483  Dim r = ChangeType(VT_CY)


484  ValCy = New Currency


485  ValCy.Cy = GetQWord(VarPtr(r.v.val))


486  End Function


487 


488  Sub ValCy(x As Currency)


489  Clear()


490  SetQWord(VarPtr(v.val), x.Cy)


491  v.vt = VT_CY


492  End Sub


493 


494  'ValDate


495 


496  Const Function ValStr() As BString


497  ValStr = New BString


498  Dim r As VARIANT


499  ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR)


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


501  End Function


502 


503  Sub ValStr(x As BString)


504  Clear()


505  v.vt = VT_BSTR


506  If IsNothing(x) Then


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


508  Else


509  SetPointer(VarPtr(v.val), x.Copy())


510  End If


511  End Sub


512 


513  Const Function ValUnknown() As IUnknown


514  Dim r As VARIANT


515  ChangeType(r, 0, VT_UNKNOWN)


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


517  End Function


518 


519  Sub ValUnknown(x As IUnknown)


520  Clear()


521  SetPointer(VarPtr(v.val), ObjPtr(x))


522  If Not IsNothing(x) Then


523  x.AddRef()


524  End If


525  v.vt = VT_UNKNOWN


526  End Sub


527  /*


528  Const Function ValObject() As VBObject


529  Dim r As VARIANT


530  ChangeType(r, 0, VT_DISPATCH)


531  Dim o As VBObject


532  o.Attach(GetPointer(VarPtr(r.val)) As *IDispatch)


533  Return o


534  End Function


535 


536  Sub ValObject(x As VBObject)


537  Clear()


538  SetPointer(VarPtr(v.val), x.Copy())


539  x>AddRef()


540  v.vt = VT_DISPATH


541  End Sub


542  */


543  'ValArray


544 


545  Const Function ValDecimal() As Decimal


546  Dim p = VarPtr(v) As *Decimal


547  Return New Deciaml(ByVal p)


548  End Function


549 


550  Sub ValDecimal(x As Decimal)


551  Clear()


552  Dim p = VarPtr(v) As *DECIMAL


553  p[0] = x.Dec


554  v.vt = VT_DECIMAL '念の為


555  End Sub


556 


557 


558  Function PtrToVariant() As *VARIANT


559  Return VarPtr(v)


560  End Function


561 


562  Static Function OptionalParam() As Variant


563  If IsNothing(optionalParam) Then


564  Dim t = New Variant


565  t.ValError = DISP_E_PARAMNOTFOUND


566  InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0)


567  End If


568  Return optionalParam


569  End Function


570 


571  Static Function Null() As Variant


572  If IsNothing(optionalParam) Then


573  Dim t = New Variant


574  Dim p = t.PtrToVariant


575  p>vt = VT_NULL


576  InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0)


577  End If


578  Return optionalParam


579  End Function


580  Private


581  v As VARIANT


582 


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


584  VariantCopy(dst, src)


585  End Sub


586 


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


588  dst = src


589  ' src.vt = VT_EMPTY


590  End Sub


591 


592  Static Function removeNull(v As Variant) As Varinat


593  If IsNothing(v) Then


594  removeNull = Null


595  Else


596  removeNull = v


597  End If


598  End Function


599 


600  Static optionalParam = Nothing As Variant


601  Static null = Nothing As Variant


602  End Class


603 


604  /*


605  Function Abs(v As Variant) As Variant


606  Return v.Abs()


607  End Function


608 


609  Function Fix(v As Variant) As Variant


610  Return v.Fix()


611  End Function


612 


613  Function Int(v As Variant) As Variant


614  Return v.Int()


615  End Function


616 


617  Function VarType(v As Variant) As VARTYPE


618  Return v.VarType()


619  End Function


620  */


621 


622  End Namespace 'COM


623  End Namespace 'ActiveBasic

