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

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