source: trunk/ab5.0/ablib/src/com/variant.ab @ 709

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

最新のコンパイラに通るように修正。参照クラスのセマンティクスに合うように修正(Setter系プロパティの削除など)。
File size: 13.2 KB
Line 
1' com/variant.ab
2
3'#require <com/index.ab>
4
5Namespace ActiveBasic
6Namespace COM
7
8Class Variant
9    Implements System.IDisposable, System.ICloneable
10Public
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
119Private
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
129Public
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
341Private
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
345Public
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
495Private
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
518End Class
519
520
521Function Abs(v As Variant) As Variant
522    Return v.Abs()
523End Function
524
525Function Fix(v As Variant) As Variant
526    Return v.Fix()
527End Function
528
529Function Int(v As Variant) As Variant
530    Return v.Int()
531End Function
532
533Function VarType(v As Variant) As VARTYPE
534    Return v.VarType()
535End Function
536
537Namespace Detail
538
539Sub CopyFromVariant(ByRef x As Byte, v As Variant)
540    x = v.ValUI1
541End Sub
542
543Sub CopyFromVariant(ByRef x As Word, v As Variant)
544    x = v.ValUI2
545End Sub
546
547Sub CopyFromVariant(ByRef x As DWord, v As Variant)
548    x = v.ValUI4
549End Sub
550
551Sub CopyFromVariant(ByRef x As QWord, v As Variant)
552    x = v.ValUI8
553End Sub
554
555Sub CopyFromVariant(ByRef x As SByte, v As Variant)
556    x = v.ValI1
557End Sub
558
559Sub CopyFromVariant(ByRef x As Integer, v As Variant)
560    x = v.ValI2
561End Sub
562
563Sub CopyFromVariant(ByRef x As Long, v As Variant)
564    x = v.ValI4
565End Sub
566
567Sub CopyFromVariant(ByRef x As Int64, v As Variant)
568    x = v.ValI8
569End Sub
570
571Sub CopyFromVariant(ByRef x As Single, v As Variant)
572    x = v.ValR4
573End Sub
574
575Sub CopyFromVariant(ByRef x As Double, v As Variant)
576    x = v.ValR8
577End Sub
578
579Sub CopyFromVariant(ByRef x As Boolean, v As Variant)
580    x = v.ValBool As Boolean
581End Sub
582
583Sub CopyFromVariant(ByRef x As ActiveBasic.COM.Currency, v As Variant)
584    x = v.ValCy
585End Sub
586
587Sub CopyFromVariant(ByRef x As String, v As Variant)
588    x = v.ValStr.ToString()
589End Sub
590
591Sub CopyFromVariant(ByRef x As ActiveBasic.COM.VBObject, v As Variant)
592    x = v.ValObject
593End Sub
594
595Sub CopyFromVariant(ByRef x As ActiveBasic.COM.Decimal, v As Variant)
596    x = v.ValDecimal
597End Sub
598
599Sub CopyFromVariant(ByRef x As IUnknown, v As Variant)
600    x = v.ValUnknown
601End Sub
602
603Sub CopyFromVariant(ByRef x As Variant, v As Variant)
604    x = v.Clone()
605End Sub
606
607End Namespace
608
609End Namespace 'COM
610End Namespace 'ActiveBasic
Note: See TracBrowser for help on using the repository browser.