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

Last change on this file since 478 was 478, checked in by イグトランス (egtra), 15 years ago

現在向けに修正（参照型のポインタの排除など）
File size: 12.9 KB
Line 
1' com/variant.ab
2
3'#require <com/index.ab>
4
5Namespace ActiveBasic
6Namespace COM
7
8Class Variant
9Public
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
580Private
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
602End Class
603
604/*
605Function Abs(v As Variant) As Variant
606    Return v.Abs()
607End Function
608
609Function Fix(v As Variant) As Variant
610    Return v.Fix()
611End Function
612
613Function Int(v As Variant) As Variant
614    Return v.Int()
615End Function
616
617Function VarType(v As Variant) As VARTYPE
618    Return v.VarType()
619End Function
620*/
621
622End Namespace 'COM
623End Namespace 'ActiveBasic
Note: See TracBrowser for help on using the repository browser.