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

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

SPrintF関連の追加。関数FloatToChars, FormatFloatE, FormatIntegerUと列挙体FormatFlags。
File size: 12.9 KB
Line 
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
10Namespace ActiveBasic
11Namespace COM
12
13Class Variant
14Public
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
606Private
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
617End Class
618
619'Dim _System_VariantOptionalParam = Nothing As Variant
620
621/*
622Function Abs(v As Variant) As Variant
623 Return v.Abs()
624End Function
625
626Function Fix(v As Variant) As Variant
627 Return v.Fix()
628End Function
629
630Function Int(v As Variant) As Variant
631 Return v.Int()
632End Function
633
634Function VarType(v As Variant) As VARTYPE
635 Return v.VarType()
636End Function
637*/
638
639End Namespace 'COM
640End Namespace 'ActiveBasic
641
642#endif '_COM_VARIANT_AB
Note: See TracBrowser for help on using the repository browser.