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

Last change on this file since 709 was 709, checked in by イグトランス (egtra), 15 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.