1  ' com/variant.ab


2 


3  #ifndef _COM_VARIANT_AB


4  #define _COM_VARIANT_AB


5 


6  '#require <oaidl.ab>


7  '#require <oleauto.ab>


8  #require <com/index.ab>


9 


10  Namespace ActiveBasic


11  Namespace COM


12 


13  Class Variant


14  Public


15  Sub Variant()


16  VariantInit(v)


17  End Sub


18 


19  Sub Variant(y As Variant)


20  VariantInit(v)


21  VariantCopy(v, y.v)


22  End Sub


23 


24  Sub Variant(ByRef y As VARIANT)


25  VariantInit(v)


26  VariantCopy(v, y)


27  End Sub


28 


29  Sub Variant(n As SByte)


30  v.vt = VT_I1


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


32  End Sub


33 


34  Sub Variant(n As Byte)


35  v.vt = VT_UI1


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


37  End Sub


38 


39  Sub Variant(n As Integer)


40  v.vt = VT_I2


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


42  End Sub


43 


44  Sub Variant(n As Word)


45  v.vt = VT_UI2


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


47  End Sub


48 


49  Sub Variant(n As Long)


50  v.vt = VT_I4


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


52  End Sub


53 


54  Sub Variant(n As DWord)


55  v.vt = VT_UI4


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


57  End Sub


58 


59  Sub Variant(n As Int64)


60  v.vt = VT_I8


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


62  End Sub


63 


64  Sub Variant(n As QWord)


65  v.vt = VT_UI8


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


67  End Sub


68 


69  Sub Variant(n As Single)


70  v.vt = VT_R4


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


72  End Sub


73 


74  Sub Variant(n As Double)


75  v.vt = VT_R8


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


77  End Sub


78 


79  Sub Variant(bs As BString)


80  v.vt = VT_BSTR


81  SetPointer(VarPtr(v.val), SysAllocStringLen(bs.BStr, bs.Length))


82  End Sub


83 


84  Sub Variant(p As *IUnknown)


85  p>AddRef()


86  v.vt = VT_UNKNOWN


87  SetPointer(VarPtr(v.val), p)


88  End Sub


89 


90  Sub Variant(p As *IDispatch)


91  p>AddRef()


92  v.vt = VT_DISPATCH


93  SetPointer(VarPtr(v.val), p)


94  End Sub


95  /*


96  Sub Variant(b As VARIANT_BOOL)


97  v.vt = VT_BOOL


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


99  End Sub


100  */


101  Sub Variant(b As Boolean)


102  v.vt = VT_BOOL


103  If b Then


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


105  Else


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


107  End If


108  End Sub


109 


110  Sub Variant(s As String)


111  Dim bs As BString(s)


112  Variant(bs)


113  End Sub


114 


115  Sub Variant(n As Currency)


116  v.vt = VT_CY


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


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 Operator =(y As Variant)


131  Assign(y.v)


132  End Sub


133 


134  Sub Operator =(y As VARIANT)


135  Assign(y)


136  End Sub


137  */


138  Sub Assign(from As Variant)


139  Assign(from.v)


140  End Sub


141 


142  Sub Assign(ByRef from As VARIANT)


143  Variant.Copy(v, from)


144  End Sub


145 


146  Sub AssignInd(ByRef from As VARIANT)


147  VariantCopyInd(v, from)


148  End Sub


149 


150  Sub Attach(ByRef from As VARIANT)


151  Variant.Move(v, from)


152  End Sub


153 


154  Const Function Copy() As VARIANT


155  Variant.Copy(Copy, v)


156  End Function


157 


158  Function Detach() As VARIANT


159  Variant.Move(Detach, v)


160  End Function


161  /*


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


163  Assign = New Variant


164  Assgin.Assign(from)


165  End Function


166 


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


168  Attach = New Variant


169  Attach.Attach(from)


170  End Function


171  */


172  'Operators


173 


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


175  Dim ret = New Variant


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


177  Return ret


178  End Function


179 


180  Const Function Operator +() As Variant


181  Return New Variant(This)


182  End Function


183 


184  Const Function Operator () As Variant


185  Dim ret = New Variant


186  VarNeg(This.v, ret.v)


187  Return ret


188  End Function


189 


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


191  Dim ret = New Variant


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


193  Return ret


194  End Function


195 


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


197  Dim ret = New Variant


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


199  Return ret


200  End Function


201 


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


203  Dim ret = New Variant


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


205  Return ret


206  End Function


207 


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


209  Dim ret = New Variant


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


211  Return ret


212  End Function


213 


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


215  Dim ret = New Variant


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


217  Return ret


218  End Function


219 


220  Const Function Operator (y As Variant) As Variant


221  Dim ret = New Variant


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


223  Return ret


224  End Function


225 


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


227  Dim ret = New Variant


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


229  Return ret


230  End Function


231 


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


233  Dim ret = New Variant


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


235  Return ret


236  End Function


237 


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


239  Dim ret = New Variant


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


241  Return ret


242  End Function


243 


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


245  Dim ret = New Variant


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


247  Return ret


248  End Function


249 


250  Const Function Operator Not() As Variant


251  Dim ret = New Variant


252  VarNot(This.v, ret.v)


253  Return ret


254  End Function


255 


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


257  Dim ret = New Variant


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


259  Return ret


260  End Function


261 


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


263  Dim ret = New Variant


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


265  Return ret


266  End Function


267 


268  Const Function Abs() As Variant


269  Dim ret = New Variant


270  VarAbs(This.v, ret.v)


271  Return ret


272  End Function


273 


274  Const Function Fix() As Variant


275  Dim ret = New Variant


276  VarFix(This.v, ret.v)


277  Return ret


278  End Function


279 


280  Const Function Int() As Variant


281  Dim ret = New Variant


282  VarInt(This.v, ret.v)


283  Return ret


284  End Function


285 


286  Const Function Round(cDecimals As Long) As Variant


287  Dim ret = New Variant


288  VarRound(This.v, cDecimals, ret)


289  Return ret


290  End Function


291 


292  Const Function Round() As Variant


293  Return Round(0)


294  End Function


295 


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


297  Return VarCmp(x.v, y.v, lcid, flags)


298  End Function


299 


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


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


302  End Function


303 


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


305  Dim c = Compare(This, y)


306  If c = VARCMP_EQ Then


307  Return True


308  Else


309  Return False


310  End If


311  End Function


312 


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


314  Dim c = Compare(This, y)


315  If c <> VARCMP_EQ Then


316  Return True


317  Else


318  Return False


319  End If


320  End Function


321 


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


323  Dim c = Compare(This, y)


324  If c = VARCMP_LT Then


325  Return True


326  Else


327  Return False


328  End If


329  End Function


330  /*


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


332  Dim c = Compare(This, y)


333  If c = VARCMP_GT Then


334  Return True


335  Else


336  Return False


337  End If


338  End Function


339  */


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


341  Dim c = Compare(This, y)


342  If c = VARCMP_LT Or c = VARCMP_EQ Then


343  Return True


344  Else


345  Return False


346  End If


347  End Function


348 


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


350  Dim c = Compare(This, y)


351  If c = VARCMP_GT Or c = VARCMP_EQ Then


352  Return True


353  Else


354  Return False


355  End If


356  End Function


357 


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


359  Dim ret = New Variant


360  ChangeType(ret, flags, vt)


361  Return ret


362  End Function


363 


364  Const Function ChangeType(vt As VARTYPE) As Variant


365  Return ChangeType(vt, 0)


366  End Function


367 


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


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


370  End Function


371 


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


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


374  End Function


375 


376  Const Function VarType() As VARTYPE


377  Return v.vt


378  End Function


379 


380  Override Function ToString() As String


381  Dim tmp = ChangeType(VT_BSTR, VARIANT_ALPHABOOL)


382  Dim bs = ((tmp.v.val As ULONG_PTR) As BSTR)


383  Return New String(bs As PCWSTR, SysStringLen(bs) As Long)


384  End Function


385 


386  Override Function GetHashCode() As Long


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


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


389  End Function


390 


391  Const Function ValUI1() As Byte


392  Dim r = ChangeType(VT_UI1)


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


394  End Function


395 


396  Sub ValUI1(x As Byte)


397  Clear()


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


399  v.vt = VT_UI1


400  End Sub


401 


402  Const Function ValUI2() As Word


403  Dim r = ChangeType(VT_UI2)


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


405  End Function


406 


407  Sub ValUI2(x As Word)


408  Clear()


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


410  v.vt = VT_UI2


411  End Sub


412 


413  Const Function ValUI4() As DWord


414  Dim r = ChangeType(VT_UI4)


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


416  End Function


417 


418  Sub ValUI4(x As DWord)


419  Clear()


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


421  v.vt = VT_UI4


422  End Sub


423 


424  Const Function ValUI8() As QWord


425  Dim r = ChangeType(VT_UI8)


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


427  End Function


428 


429  Sub ValUI8(x As QWord)


430  Clear()


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


432  v.vt = VT_UI8


433  End Sub


434 


435  Const Function ValI1() As SByte


436  Dim r = ChangeType(VT_I1)


437  Return GetByte(VarPtr(r.val)) As SByte


438  End Function


439 


440  Sub ValI1(x As SByte)


441  Clear()


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


443  v.vt = VT_I1


444  End Sub


445 


446  Const Function ValI2() As Integer


447  Dim r = ChangeType(VT_I2)


448  Return GetWord(VarPtr(r.val)) As Integer


449  End Function


450 


451  Sub ValI2(x As Integer)


452  Clear()


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


454  v.vt = VT_I2


455  End Sub


456 


457  Const Function ValI4() As Long


458  Dim r = ChangeType(VT_I4)


459  Return GetDWord(VarPtr(r.val)) As Long


460  End Function


461 


462  Sub ValI4(x As Long)


463  Clear()


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


465  v.vt = VT_I4


466  End Sub


467 


468  Const Function ValI8() As Int64


469  Dim r = ChangeType(VT_I8)


470  Return GetQWord(VarPtr(r.val)) As Int64


471  End Function


472 


473  Sub ValI8(x As Int64)


474  Clear()


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


476  v.vt = VT_I8


477  End Sub


478 


479  Const Function ValR4() As Single


480  Dim r = ChangeType(VT_R4)


481  Return GetSingle(VarPtr(r.val))


482  End Function


483 


484  Sub ValR4(x As Single)


485  Clear()


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


487  v.vt = VT_R4


488  End Sub


489 


490  Const Function ValR8() As Double


491  Dim r = ChangeType(VT_UI8)


492  Return GetDouble(VarPtr(r.val))


493  End Function


494 


495  Sub ValR8(x As Double)


496  Clear()


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


498  v.vt = VT_R8


499  End Sub


500 


501  Const Function ValBool() As VARIANT_BOOL


502  Dim r = ChangeType(VT_BOOL)


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


504  End Function


505 


506  Sub ValBool(x As VARIANT_BOOL)


507  Clear()


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


509  v.vt = VT_BOOL


510  End Sub


511 


512  Const Function ValError() As SCODE


513  Dim r = ChangeType(VT_ERROR)


514  Return GetDWord(VarPtr(r.val))


515  End Function


516 


517  Sub ValError(x As SCODE)


518  Clear()


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


520  v.vt = VT_ERROR


521  End Sub


522 


523  Const Function ValCy() As Currency


524  Dim r = ChangeType(VT_CY)


525  ValCy = New Currency


526  ValCy.Cy = GetQWord(VarPtr(r.val))


527  End Function


528 


529  Sub ValCy(x As Currency)


530  Clear()


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


532  v.vt = VT_CY


533  End Sub


534 


535  'ValDate


536 


537  Const Function ValStr() As BString


538  Dim r As VARIANT


539  ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR)


540  Dim bs = New BString


541  bs.Attach(GetPointer(VarPtr(r.val)) As BSTR)


542  Return bs


543  End Function


544 


545  Sub ValStr(x As BString)


546  Clear()


547  v.vt = VT_BSTR


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


549  End Sub


550 


551  Const Function ValUnknown() As *IUnknown


552  Dim r As VARIANT


553  ChangeType(r, 0, VT_UNKNOWN)


554  Return GetPointer(VarPtr(r.val)) As *IUnknown


555  End Function


556 


557  Sub ValUnknown(x As *IUnknown)


558  Clear()


559  SetPointer(VarPtr(v.val), x)


560  x>AddRef()


561  v.vt = VT_UNKNOWN


562  End Sub


563 


564  Const Function ValObject() As VBObject


565  Dim r As VARIANT


566  ChangeType(r, 0, VT_DISPATCH)


567  Dim o As VBObject


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


569  Return o


570  End Function


571 


572  Sub ValObject(x As VBObject)


573  Clear()


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


575  x>AddRef()


576  v.vt = VT_DISPATH


577  End Sub


578 


579  'ValArray


580 


581  Const Function ValDecimal() As Decimal


582  Dim p = VarPtr(v) As *Decimal


583  Return New Deciaml(p[0])


584  End Function


585 


586  Sub ValDecimal(x As Decimal)


587  Clear()


588  Dim p = VarPtr(v) As *Decimal


589  p[0] = x.Dec


590  v.vt = VT_DECIMAL '念の為


591  End Sub


592 


593 


594  Function PtrToVariant() As *VARIANT


595  Return VarPtr(v)


596  End Function


597 


598  Static Function OptionalParam() As Variant


599  ' If _System_VariantOptionalParam = Nothing Then


600  ' 'ToDo マルチスレッド対応


601  _System_VariantOptionalParam = New Variant


602  _System_VariantOptionalParam.ValError = DISP_E_PARAMNOTFOUND


603  ' End If


604  Return _System_VariantOptionalParam


605  End Function


606  Private


607  v As VARIANT


608 


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


610  VariantCopy(dst, src)


611  End Sub


612 


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


614  dst = src


615  ' src.vt = VT_EMPTY


616  End Sub


617  End Class


618 


619  'Dim _System_VariantOptionalParam = Nothing As Variant


620 


621  /*


622  Function Abs(v As Variant) As Variant


623  Return v.Abs()


624  End Function


625 


626  Function Fix(v As Variant) As Variant


627  Return v.Fix()


628  End Function


629 


630  Function Int(v As Variant) As Variant


631  Return v.Int()


632  End Function


633 


634  Function VarType(v As Variant) As VARTYPE


635  Return v.VarType()


636  End Function


637  */


638 


639  End Namespace 'COM


640  End Namespace 'ActiveBasic


641 


642  #endif '_COM_VARIANT_AB

