Changeset 709


Ignore:
Timestamp:
2009/06/29 04:03:45 (3 years ago)
Author:
egtra
Message:

最新のコンパイラに通るように修正。参照クラスのセマンティクスに合うように修正(Setter系プロパティの削除など)。

Location:
trunk/ab5.0/ablib/src/com
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • trunk/ab5.0/ablib/src/com/bstring.ab

    r478 r709  
    55 
    66Class BString 
    7     Implements System.IDisposable ', System.ICloneable 
     7    Implements System.IDisposable, System.ICloneable 
    88Public 
    99    Sub BString() 
    … …  
    1515    End Sub 
    1616 
    17     Sub BString(s As BString) 
    18         If Not IsNothing(s) Then 
    19             bs = copy(s.bs) 
    20         End If 
    21     End Sub 
    22  
    2317    Sub BString(s As LPCOLESTR, len As DWord) 
    24         If s <> 0 Then 
    25             bs = SysAllocStringLen(s, len) 
    26         End If 
     18        init(s, len) 
    2719    End Sub 
    2820 
    2921    Sub BString(s As String) 
    3022        If Not IsNothing(s) Then 
    31             Init(s.StrPtr, s.Length As DWord) 
     23            init(s.StrPtr, s.Length As DWord) 
    3224        End If 
    3325    End Sub 
    … …  
    7365    End Function 
    7466 
    75     /*Override*/ Function Clone() As BString 
    76         Return New BString(This) 
    77     End Function 
    78  
    79     /*Override*/ Sub Dispose() 
     67    Function Clone() As BString 
     68        Return New BString(bs, Length) 
     69    End Function 
     70 
     71    Sub Dispose() 
    8072        Clear() 
    8173    End Sub 
    … …  
    10395 
    10496    Const Function Length() As DWord 
    105         Length = GetDWord(bs As VoidPtr - SizeOf (DWord)) 'SysStringLen(bs) 
     97        Length = SysStringLen(bs) 
    10698    End Function 
    10799 
    108100    Const Function Operator [](i As SIZE_T) As OLECHAR 
    109101        If i > Length Then 
    110             Throw New ArgumentOutOfRangeException("i") 
     102            Throw New System.ArgumentOutOfRangeException("i - BString.Operator [] (get)") 
    111103        End If 
    112104        Return bs[i] 
    … …  
    115107    Sub Operator []=(i As SIZE_T, c As OLECHAR) 
    116108        If i > Length Then 
    117             Throw New ArgumentOutOfRangeException("i") 
     109            Throw New System.ArgumentOutOfRangeException("i - BString.Operator [] (set)") 
    118110        End If 
    119111        bs[i] = c 
    … …  
    148140            End If 
    149141        Else 
    150             If IsNullOrEmpty(bsr) Then 
     142            If IsNullOrEmpty(r) Then 
    151143                Compare = 1 
    152144            Else 
    … …  
    156148    End Function 
    157149 
    158     Static Function IsNullOrEmpty(s As BString) 
     150    Static Function IsNullOrEmpty(s As BString) As Boolean 
    159151        If IsNothing(s) Then 
    160152            IsNullOrEmpty = True 
    … …  
    196188 
    197189    Sub init(s As PCSTR, len As DWord) 
    198         If <> 0 Then 
    199             Dim lenBS = MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, 0, 0) 
     190        If s <> 0 Then 
     191            Dim lenBS = MultiByteToWideChar(CP_ACP, 0, s, len As Long, 0, 0) 
    200192            bs = SysAllocStringLen(0, lenBS) 
    201193            If bs <> 0 Then 
    202                 MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, bs, lenBS) 
    203             End If 
     194                MultiByteToWideChar(CP_ACP, 0, s, len As Long, bs, lenBS) 
     195            End If 
     196        End If 
     197    End Sub 
     198 
     199    Sub init(s As PCWSTR, len As DWord) 
     200        If s <> 0 Then 
     201            bs = SysAllocStringLen(s, len) 
    204202        End If 
    205203    End Sub 
    206204 
    207205    Sub reset(newBS As BSTR) 
    208         Dim old = InterlockedExchangePointer(bs, newBS) 
     206        Dim old = InterlockedExchangePointer(ByVal VarPtr(bs) As *VoidPtr, newBS) 
    209207        SysFreeString(old) 
    210208    End Sub 
    … …  
    215213 
    216214    Static Function move(ByRef src As BSTR) As BSTR 
    217         move = InterlockedExchangePointer(src, 0) 
     215        move = InterlockedExchangePointer(ByVal VarPtr(src) As *VoidPtr, 0) 
    218216    End Function 
    219217End Class 

  • trunk/ab5.0/ablib/src/com/currency.ab

    r478 r709  
    77 
    88Class Currency 
     9    Implements System.ICloneable, System.IEquatable<Currency>', System.IComparable<Currency> 
    910Public 
    1011    Sub Currency() 
    1112        cy = 0 
    1213    End Sub 
    13  
    1414/* 
    1515    Sub Currency(x As CY) 
    … …  
    2525    End Sub 
    2626*/ 
    27 /* 
    28     Const Function Operator +() As Currency 
    29         Return New Currency(This) 
    30     End Function 
    31 */ 
    32     Const Function Operator -() As Currency 
    33         Dim ret = New Currency 
    34         VarCyNeg(This.cy, ret.cy) 
    35         Return ret 
    36     End Function 
    37  
    38     Const Function Operator *(y As Currency) As Currency 
    39         Dim ret = New Currency 
    40         VarCyMul(This.cy, y.cy, ret.cy) 
    41         Return ret 
    42     End Function 
    43  
    44     Const Function Operator *(y As Long) As Currency 
    45         Dim ret = New Currency 
    46         VarCyMulI4(This.cy, y, ret.cy) 
    47         Return ret 
    48     End Function 
    49  
    50     Const Function Operator *(y As Int64) As Currency 
    51         Dim ret = New Currency 
    52         VarCyMulI8(This.cy, y, ret.cy) 
    53         Return ret 
    54     End Function 
    55  
    56     Const Function Operator /(y As Variant) As Double 
     27    Static Function FromCy(cy As CY) As Currency 
     28        FromCy = New Currency 
     29        FromCy.cy = cy 
     30    End Function 
     31 
     32    Function Operator +() As Currency 
     33        Return FromCy(cy) 
     34    End Function 
     35 
     36    Function Operator -() As Currency 
     37        Dim ret = New Currency 
     38        Windows.ThrowIfFailed(VarCyNeg(This.cy, ret.cy)) 
     39        Return ret 
     40    End Function 
     41 
     42    Function Operator *(y As Currency) As Currency 
     43        Dim ret = New Currency 
     44        Windows.ThrowIfFailed(VarCyMul(This.cy, y.cy, ret.cy)) 
     45        Return ret 
     46    End Function 
     47 
     48    Function Operator *(y As Long) As Currency 
     49        Dim ret = New Currency 
     50        Windows.ThrowIfFailed(VarCyMulI4(This.cy, y, ret.cy)) 
     51        Return ret 
     52    End Function 
     53 
     54    Function Operator *(y As Int64) As Currency 
     55        Dim ret = New Currency 
     56        Windows.ThrowIfFailed(VarCyMulI8(This.cy, y, ret.cy)) 
     57        Return ret 
     58    End Function 
     59 
     60    Function Operator /(y As Variant) As Double 
    5761        Dim vx = New Variant(This) 
    5862        Dim ret = vx / y 
    … …  
    6064    End Function 
    6165 
    62     Const Function Operator /(y As Currency) As Double 
     66    Function Operator /(y As Currency) As Double 
    6367        Dim vx = New Variant(This) 
    6468        Dim vy = New Variant(y) 
    … …  
    6771    End Function 
    6872 
    69     Const Function Operator +(y As Currency) As Currency 
    70         Dim ret = New Currency 
    71         VarCyAdd(This.cy, y.cy, ret.cy) 
    72         Return ret 
    73     End Function 
    74  
    75     Const Function Operator -(y As Currency) As Currency 
    76         Dim ret = New Currency 
    77         VarCySub(This.cy, y.cy, ret.cy) 
     73    Function Operator +(y As Currency) As Currency 
     74        Dim ret = New Currency 
     75        Windows.ThrowIfFailed(VarCyAdd(This.cy, y.cy, ret.cy)) 
     76        Return ret 
     77    End Function 
     78 
     79    Function Operator -(y As Currency) As Currency 
     80        Dim ret = New Currency 
     81        Windows.ThrowIfFailed(VarCySub(This.cy, y.cy, ret.cy)) 
    7882        Return ret 
    7983    End Function 
    … …  
    99103    End Function 
    100104 
    101     Const Function Operator ==(y As Currency) As Boolean 
     105    Function Operator ==(y As Currency) As Boolean 
    102106        Dim c = Compare(This, y) 
    103107        Return c = VARCMP_EQ 
    104108    End Function 
    105109 
    106     Const Function Operator ==(y As Double) As Boolean 
     110    Function Operator ==(y As Double) As Boolean 
    107111        Dim c = Compare(This, y) 
    108112        Return c = VARCMP_EQ 
    109113    End Function 
    110114 
    111     Const Function Operator <>(y As Currency) As Boolean 
     115    Function Operator <>(y As Currency) As Boolean 
    112116        Dim c = Compare(This, y) 
    113117        Return c <> VARCMP_EQ 
    114118    End Function 
    115119 
    116     Const Function Operator <>(y As Double) As Boolean 
     120    Function Operator <>(y As Double) As Boolean 
    117121        Dim c = Compare(This, y) 
    118122        Return c <> VARCMP_EQ 
    119123    End Function 
    120124 
    121     Const Function Operator <(y As Currency) As Boolean 
     125    Function Operator <(y As Currency) As Boolean 
    122126        Dim c = Compare(This, y) 
    123127        Return c = VARCMP_LT 
    124128    End Function 
    125129 
    126     Const Function Operator <(y As Double) As Boolean 
     130    Function Operator <(y As Double) As Boolean 
    127131        Dim c = Compare(This, y) 
    128132        Return c = VARCMP_LT 
    129133    End Function 
    130134 
    131     Const Function Operator >(y As Currency) As Boolean 
     135    Function Operator >(y As Currency) As Boolean 
    132136        Dim c = Compare(This, y) 
    133137        Return c = VARCMP_GT 
    134138    End Function 
    135139 
    136     Const Function Operator >(y As Double) As Boolean 
     140    Function Operator >(y As Double) As Boolean 
    137141        Dim c = Compare(This, y) 
    138142        Return c = VARCMP_GT 
    139143    End Function 
    140144 
    141     Const Function Operator <=(y As Currency) As Boolean 
     145    Function Operator <=(y As Currency) As Boolean 
    142146        Dim c = Compare(This, y) 
    143147        Return c = VARCMP_LT Or c = VARCMP_EQ 
    144148    End Function 
    145149 
    146     Const Function Operator <=(y As Double) As Boolean 
     150    Function Operator <=(y As Double) As Boolean 
    147151        Dim c = Compare(This, y) 
    148152        Return c = VARCMP_LT Or c = VARCMP_EQ 
    149153    End Function 
    150154 
    151     Const Function Operator >=(y As Currency) As Boolean 
     155    Function Operator >=(y As Currency) As Boolean 
    152156        Dim c = Compare(This, y) 
    153157        Return c = VARCMP_GT Or c = VARCMP_EQ 
    154158    End Function 
    155159 
    156     Const Function Operator >=(y As Double) As Boolean 
     160    Function Operator >=(y As Double) As Boolean 
    157161        Dim c = Compare(This, y) 
    158162        Return c = VARCMP_GT Or c = VARCMP_EQ 
    159163    End Function 
    160164 
    161     Const Function Abs() As Currency 
     165    Function Abs() As Currency 
    162166        Abs = New Currency 
    163         VarCyAbs(This.cy, Abs.cy) 
    164     End Function 
    165  
    166     Const Function Fix() As Currency 
     167        Windows.ThrowIfFailed(VarCyAbs(This.cy, Abs.cy)) 
     168    End Function 
     169 
     170    Function Fix() As Currency 
    167171        Fix = New Currency 
    168         VarCyFix(This.cy, Fix.cy) 
    169     End Function 
    170  
    171     Const Function Int() As Currency 
     172        Windows.ThrowIfFailed(VarCyFix(This.cy, Fix.cy)) 
     173    End Function 
     174 
     175    Function Int() As Currency 
    172176        Int = New Currency 
    173         VarCyInt(This.cy, Int.cy) 
    174     End Function 
    175  
    176     Const Function Round(c = 0 As Long) As Currency 
     177        Windows.ThrowIfFailed(VarCyInt(This.cy, Int.cy)) 
     178    End Function 
     179 
     180    Function Round(c = 0 As Long) As Currency 
    177181        Round = New Currency 
    178         VarCyRound(This.cy, c, Round.cy) 
    179     End Function 
    180  
    181     Const Function Cy() As CY 
     182        Windows.ThrowIfFailed(VarCyRound(This.cy, c, Round.cy)) 
     183    End Function 
     184 
     185    Function Cy() As CY 
    182186        Cy = cy 
    183187    End Function 
    184188 
    185     Sub Cy(c As CY) 
    186         cy = c 
    187     End Sub 
    188  
    189     Const Function ToDouble() As Double 
     189    Function ToDouble() As Double 
    190190        VarR8FromCy(cy, ToDouble) 
    191191    End Function 
    192192 
    193     Const Function ToInt64() As Int64 
     193    Function ToInt64() As Int64 
    194194        VarI8FromCy(cy, ToInt64) 
    195195    End Function 
    196196 
    197     Const Function ToVariant() As Variant 
     197    Function ToVariant() As Variant 
    198198        Return New Variant(This) 
    199199    End Function 
    200200 
    201201    Override Function ToString() As String 
    202         /*Using*/ Dim bstr = New BString 
     202        Using bstr = New BString 
    203203            Dim bs As BSTR 
    204204            VarBstrFromCy(cy, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) 
    205205            bstr.Attach(bs) 
    206             ToString = bstr.ToString 
    207         bstr.Dispose() 'End Using 
     206            ToString = bstr.ToString() 
     207        End Using 
    208208    End Function 
    209209 
    210210    Override Function GetHashCode() As Long 
    211         Return HIDWORD(cy) Xor LODWORD(cy) 
     211        Return (HIDWORD(cy) Xor LODWORD(cy)) As Long 
     212    End Function 
     213 
     214    Override Function Equals(y As Object) As Boolean 
     215        If This.GetType().Equals(y.GetType()) Then 
     216            Equals = Equals(y As Currency) 
     217        Else 
     218            Equals = False 
     219        End If 
    212220    End Function 
    213221 
    … …  
    215223        Dim c = Compare(This, y) 
    216224        Return c = VARCMP_EQ 
     225    End Function 
     226 
     227    Function CompareTo(y As Currency) As Long 
     228        Dim c = Compare(This, y) 
     229        If c = VARCMP_GT Then 
     230            CompareTo = 1 
     231        ElseIf c = VARCMP_LT Then 
     232            CompareTo = -1 
     233        Else 
     234            CompareTo = 0 
     235        End If 
     236    End Function 
     237 
     238    Function Clone() As Currency 
     239        Clone = This 
    217240    End Function 
    218241Private 

  • trunk/ab5.0/ablib/src/com/decimal.ab

    r478 r709  
    88 
    99Class Decimal 
     10    Implements System.ICloneable, System.IEquatable<Decimal>', System.IComparable<Decimal> 
    1011Public 
     12 
    1113    Sub Decimal() 
    1214    End Sub 
    … …  
    2224    Sub Decimal(lo As Long, mid As Long, hi As Long, isNegative As Boolean, scale As Byte) 
    2325        If scale > 28 Then 
    24             Throw New ArgumentOutOfRangeException("scale") 
     26            Throw New System.ArgumentOutOfRangeException("scale - Decimal constructor") 
    2527        End If 
    2628        Dim sign As Byte 
    … …  
    3638 
    3739    Sub Decimal(x As Long) 
    38         VarDecFromI4(x, dec) 
     40        Windows.ThrowIfFailed(VarDecFromI4(x, dec)) 
    3941    End Sub 
    4042 
    4143    Sub Decimal(x As DWord) 
    42         VarDecFromUI4(x, dec) 
     44        Windows.ThrowIfFailed(VarDecFromUI4(x, dec)) 
    4345    End Sub 
    4446 
    4547    Sub Decimal(x As Int64) 
    46         VarDecFromI8(x, dec) 
     48        Windows.ThrowIfFailed(VarDecFromI8(x, dec)) 
    4749    End Sub 
    4850 
    4951    Sub Decimal(x As QWord) 
    50         VarDecFromUI8(x, dec) 
     52        Windows.ThrowIfFailed(VarDecFromUI8(x, dec)) 
    5153    End Sub 
    5254 
    5355    Sub Decimal(x As Single) 
    54         VarDecFromR4(x, dec) 
     56        Windows.ThrowIfFailed(VarDecFromR4(x, dec)) 
    5557    End Sub 
    5658 
    5759    Sub Decimal(x As Double) 
    58         VarDecFromR8(x, dec) 
    59     End Sub 
    60 /* 
     60        Windows.ThrowIfFailed(VarDecFromR8(x, dec)) 
     61    End Sub 
     62 
    6163    Const Function Operator() As Variant 
    6264        Return New Variant(This) 
    … …  
    197199    End Function 
    198200*/ 
    199 /* 
     201 
    200202    Const Function Operator +() As Decimal 
    201203        Return New Decimal(dec) 
    202204    End Function 
    203 */ 
     205 
    204206    Const Function Operator -() As Decimal 
    205207        Dim ret = New Decimal 
    206         VarDecNeg(This.dec, ret.dec) 
     208        Windows.ThrowIfFailed(VarDecNeg(This.dec, ret.dec)) 
    207209        Return ret 
    208210    End Function 
    … …  
    210212    Const Function Operator *(y As Decimal) As Decimal 
    211213        Dim ret = New Decimal 
    212         VarDecMul(This.dec, y.dec, ret.dec) 
     214        Windows.ThrowIfFailed(VarDecMul(This.dec, y.dec, ret.dec)) 
    213215        Return ret 
    214216    End Function 
    … …  
    216218    Const Function Operator /(y As Decimal) As Decimal 
    217219        Dim ret = New Decimal 
    218         VarDecDiv(This.dec, y.dec, ret.dec) 
     220        Windows.ThrowIfFailed(VarDecDiv(This.dec, y.dec, ret.dec)) 
    219221        Return ret 
    220222    End Function 
    … …  
    222224    Const Function Operator +(y As Decimal) As Decimal 
    223225        Dim ret = New Decimal 
    224         VarDecAdd(This.dec, y.dec, ret.dec) 
     226        Windows.ThrowIfFailed(VarDecAdd(This.dec, y.dec, ret.dec)) 
    225227        Return ret 
    226228    End Function 
    … …  
    228230    Const Function Operator -(y As Decimal) As Decimal 
    229231        Dim ret = New Decimal 
    230         VarDecSub(This.dec, y.dec, ret.dec) 
    231         Return ret 
    232     End Function 
    233  
     232        Windows.ThrowIfFailed(VarDecSub(This.dec, y.dec, ret.dec)) 
     233        Return ret 
     234    End Function 
     235 
     236    ' ThrowIfFailedしていないことに注意 
    234237    Static Function Compare(x As Decimal, y As Decimal) As HRESULT 
    235         Return VarDecCmp(x.dec, y.dec) 
    236     End Function 
    237  
     238        Compare = VarDecCmp(x.dec, y.dec) 
     239    End Function 
     240 
     241    ' ThrowIfFailedしていないことに注意 
    238242    Static Function Compare(x As Decimal, y As Double) As HRESULT 
    239243        Return VarDecCmpR8(x.dec, y) 
    … …  
    314318    Const Function Abs() As Decimal 
    315319        Abs = New Decimal 
    316         VarDecAbs(This.dec, Abs.dec) 
     320        Windows.ThrowIfFailed(VarDecAbs(This.dec, Abs.dec)) 
    317321    End Function 
    318322 
    319323    Const Function Fix() As Decimal 
    320324        Fix = New Decimal 
    321         VarDecFix(This.dec, Fix.dec) 
     325        Windows.ThrowIfFailed(VarDecFix(This.dec, Fix.dec)) 
    322326    End Function 
    323327 
    324328    Const Function Int() As Decimal 
    325329        Int = New Decimal 
    326         VarDecInt(This.dec, Int.dec) 
     330        Windows.ThrowIfFailed(VarDecInt(This.dec, Int.dec)) 
    327331    End Function 
    328332 
    329333    Const Function Round(c = 0 As Long) As Decimal 
    330334        Round = New Decimal 
    331         VarDecRound(This.dec, c, Round.dec) 
     335        Windows.ThrowIfFailed(VarDecRound(This.dec, c, Round.dec)) 
    332336    End Function 
    333337 
    … …  
    336340    End Function 
    337341 
    338     Sub Dec(ByRef d As DECIMAL) 
    339         dec = d 
    340     End Sub 
    341  
    342342    Const Function ToVariant() As Variant 
    343343        Return New Variant(This) 
    344344    End Function 
    345345 
     346    Function ToBString() As BString 
     347        ToBString = New BString 
     348        Dim bs As BSTR 
     349        VarBstrFromDec(dec, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) 
     350        ToBString.Attach(bs) 
     351    End Function 
     352 
    346353    Override Function ToString() As String 
    347         /*Using*/ Dim bstr = New BString 
    348             Dim bs As BSTR 
    349             VarBstrFromDec(dec, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) 
    350             bstr.Attach(bs) 
     354        Using bstr = ToBString() 
    351355            ToString = bstr.ToString 
    352         bstr.Dispose() 'End Using 
     356        End Using 
    353357    End Function 
    354358 
    … …  
    362366        Return c = VARCMP_EQ 
    363367    End Function 
     368 
     369    Override Function Equals(y As Object) As Boolean 
     370        If This.GetType().Equals(y.GetType()) Then 
     371            Equals = Equals(y As Decimal) 
     372        End If 
     373    End Function 
     374 
     375    Function Clone() As Decimal 
     376        Clone = New Decimal(This) 
     377    End Function 
     378 
    364379Private 
    365380    dec As DECIMAL 

  • trunk/ab5.0/ablib/src/com/index.ab

    r497 r709  
    11#require <com/bstring.ab> 
    22#require <com/variant.ab> 
    3 '#require <com/vbobject.ab> 
     3#require <com/vbobject.ab> 
    44#require <com/currency.ab> 
    55#require <com/decimal.ab> 

  • trunk/ab5.0/ablib/src/com/variant.ab

    r478 r709  
    77 
    88Class Variant 
     9    Implements System.IDisposable, System.ICloneable 
    910Public 
    1011    Sub Variant() 
    … …  
    1213    End Sub 
    1314 
     15    Sub Variant(ByRef y As VARIANT) 
     16        VariantInit(v) 
     17        VariantCopy(v, y) 
     18    End Sub 
     19 
     20    ' 仮 
    1421    Sub Variant(y As Variant) 
    1522        VariantInit(v) 
    … …  
    1724    End Sub 
    1825 
    19     Sub Variant(ByRef y As VARIANT) 
    20         VariantInit(v) 
    21         VariantCopy(v, y) 
    22     End Sub 
    23  
    2426    Sub Variant(n As SByte) 
    2527        v.vt = VT_I1 
    … …  
    7476    Sub Variant(bs As BString) 
    7577        v.vt = VT_BSTR 
    76         SetPointer(VarPtr(v.val), bs.Copy)) 
     78        SetPointer(VarPtr(v.val), bs.Copy()) 
    7779    End Sub 
    7880 
    7981    Sub Variant(unk As IUnknown) 
    80         If Not IsNothing(unk) Then unk.AddRef() 
     82        If ObjPtr(unk) <> 0 Then unk.AddRef() 
    8183        v.vt = VT_UNKNOWN 
    8284        SetPointer(VarPtr(v.val), ObjPtr(unk)) 
    … …  
    8486 
    8587    Sub Variant(disp As IDispatch) 
    86         If Not IsNothing(disp) Then disp.AddRef() 
     88        If ObjPtr(disp) <> 0 Then disp.AddRef() 
    8789        v.vt = VT_DISPATCH 
    8890        SetPointer(VarPtr(v.val), ObjPtr(disp)) 
    … …  
    104106 
    105107    Sub Variant(s As String) 
    106         ValStr = New BString(s) 
    107     End Sub 
     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 
    108130 
    109131    Sub Variant(n As Currency) 
    … …  
    118140    End Sub 
    119141 
    120  
    121142    Sub ~Variant() 
    122         Clear() 
    123     End Sub 
    124  
    125     Sub Clear() 
     143        Dispose() 
     144    End Sub 
     145 
     146    Sub Dispose() 
    126147        VariantClear(v) 
    127148        v.vt = VT_EMPTY 
    128149    End Sub 
    129150 
    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 
     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 
    147160        Variant.Copy(Copy, v) 
    148161    End Function 
    … …  
    151164        Variant.Move(Detach, v) 
    152165    End Function 
    153 /* 
    154     Static Function Assgin(ByRef from As VARIANT) As Variant 
    155         Assign = New Variant 
    156         Assgin.Assign(from) 
     166 
     167    Static Function CopyFrom(ByRef from As VARIANT) As Variant 
     168        CopyFrom = New Variant 
     169        Variant.Copy(CopyFrom.v, from) 
    157170    End Function 
    158171 
    159172    Static Function Attach(ByRef from As VARIANT) As Variant 
    160173        Attach = New Variant 
    161         Attach.Attach(from) 
    162     End Function 
    163 */ 
     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 
    164182    'Operators 
    165183/* 
    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) 
     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)) 
    245263        Return ret 
    246264    End Function 
    … …  
    248266    Static Function Imp(x As Variant, y As Variant) As Variant 
    249267        Dim ret = New Variant 
    250         VarImp(x.v, y.v, ret.v) 
     268        Windows.ThrowIfFailed(VarImp(x.v, y.v, ret.v)) 
    251269        Return ret 
    252270    End Function 
    … …  
    254272    Static Function Eqv(x As Variant, y As Variant) As Variant 
    255273        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 
     274        Windows.ThrowIfFailed(VarEqv(x.v, y.v, ret.v)) 
     275        Return ret 
     276    End Function 
     277 
     278    Function Abs() As Variant 
    261279        Abs = New Variant 
    262         VarAbs(This.v, Abs.v) 
    263     End Function 
    264  
    265     Const Function Fix() As Variant 
     280        Windows.ThrowIfFailed(VarAbs(This.v, Abs.v)) 
     281    End Function 
     282 
     283    Function Fix() As Variant 
    266284        Fix = New Variant 
    267         VarFix(This.v, Fix.v) 
    268     End Function 
    269  
    270     Const Function Int() As Variant 
     285        Windows.ThrowIfFailed(VarFix(This.v, Fix.v)) 
     286    End Function 
     287 
     288    Function Int() As Variant 
    271289        Int = New Variant 
    272         VarInt(This.v, Int.v) 
    273     End Function 
    274  
    275     Const Function Round(cDecimals = 0 As Long) As Variant 
     290        Windows.ThrowIfFailed(VarInt(This.v, Int.v)) 
     291    End Function 
     292 
     293    Function Round(cDecimals = 0 As Long) As Variant 
    276294        Round = New Variant 
    277         VarRound(This.v, cDecimals, Round.v) 
    278     End Function 
    279  
     295        Windows.ThrowIfFailed(VarRound(This.v, cDecimals, Round.v)) 
     296    End Function 
     297 
     298    ' ThrowIfFailedを使っていないことに注意 
    280299    Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT 
    281300        Return VarCmp(removeNull(x).v, removeNull(y).v, lcid, flags) 
    … …  
    286305    End Function 
    287306 
    288     Const Function Operator ==(y As Variant) As Boolean 
     307    Function Operator ==(y As Variant) As Boolean 
    289308        Dim c = Compare(This, y) 
    290309        Return c = VARCMP_EQ 
    291310    End Function 
    292311 
    293     Const Function Operator <>(y As Variant) As Boolean 
     312    Function Operator <>(y As Variant) As Boolean 
    294313        Dim c = Compare(This, y) 
    295314        Return c <> VARCMP_EQ 
    296315    End Function 
    297316 
    298     Const Function Operator <(y As Variant) As Boolean 
     317    Function Operator <(y As Variant) As Boolean 
    299318        Dim c = Compare(This, y) 
    300319        Return c = VARCMP_LT 
    301320    End Function 
    302321 
    303     Const Function Operator >(y As Variant) As Boolean 
     322    Function Operator >(y As Variant) As Boolean 
    304323        Dim c = Compare(This, y) 
    305324        Return c = VARCMP_GT 
    306325    End Function 
    307326 
    308     Const Function Operator <=(y As Variant) As Boolean 
     327    Function Operator <=(y As Variant) As Boolean 
    309328        Dim c = Compare(This, y) 
    310329        Return c = VARCMP_LT Or c = VARCMP_EQ 
    311330    End Function 
    312331 
    313     Const Function Operator >=(y As Variant) As Boolean 
     332    Function Operator >=(y As Variant) As Boolean 
    314333        Dim c = Compare(This, y) 
    315334        Return c = VARCMP_GT Or c = VARCMP_EQ 
    316335    End Function 
    317336 
    318     Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant 
     337    Function ChangeType(vt As VARTYPE, flags = 0 As Word) As Variant 
    319338        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 
     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 
    336348        Return v.vt 
    337349    End Function 
    338350 
    339351    Override Function ToString() As String 
    340         /*Using*/ Dim bs = ValStr 
    341         ToString = bs.ToString 
    342         bstr.Dispose() 'End Using 
     352        Using bs = ValStr 
     353            ToString = bs.ToString() 
     354        End Using 
    343355    End Function 
    344356 
    … …  
    348360    End Function 
    349361 
    350     Const Function ValUI1() As Byte 
     362    Function ValUI1() As Byte 
    351363        Dim r = ChangeType(VT_UI1) 
    352364        Return GetByte(VarPtr(r.v.val)) 
    353365    End Function 
    354366 
    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 
     367    Function ValUI2() As Word 
    362368        Dim r = ChangeType(VT_UI2) 
    363369        Return GetWord(VarPtr(r.v.val)) 
    364370    End Function 
    365371 
    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 
     372    Function ValUI4() As DWord 
    373373        Dim r = ChangeType(VT_UI4) 
    374374        Return GetDWord(VarPtr(r.v.val)) 
    375375    End Function 
    376376 
    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 
     377    Function ValUI8() As QWord 
    384378        Dim r = ChangeType(VT_UI8) 
    385379        Return GetQWord(VarPtr(r.v.val)) 
    386380    End Function 
    387381 
    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 
     382    Function ValI1() As SByte 
    395383        Dim r = ChangeType(VT_I1) 
    396384        Return GetByte(VarPtr(r.v.val)) As SByte 
    397385    End Function 
    398386 
    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 
     387    Function ValI2() As Integer 
    406388        Dim r = ChangeType(VT_I2) 
    407389        Return GetWord(VarPtr(r.v.val)) As Integer 
    408390    End Function 
    409391 
    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 
     392    Function ValI4() As Long 
    417393        Dim r = ChangeType(VT_I4) 
    418394        Return GetDWord(VarPtr(r.v.val)) As Long 
    419395    End Function 
    420396 
    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 
     397    Function ValI8() As Int64 
    428398        Dim r = ChangeType(VT_I8) 
    429399        Return GetQWord(VarPtr(r.v.val)) As Int64 
    430400    End Function 
    431401 
    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 
     402    Function ValR4() As Single 
    439403        Dim r = ChangeType(VT_R4) 
    440404        Return GetSingle(VarPtr(r.v.val)) 
    441405    End Function 
    442406 
    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 
     407    Function ValR8() As Double 
    450408        Dim r = ChangeType(VT_UI8) 
    451409        Return GetDouble(VarPtr(r.v.val)) 
    452410    End Function 
    453411 
    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 
     412    Function ValBool() As VARIANT_BOOL 
    461413        Dim r = ChangeType(VT_BOOL) 
    462414        Return GetWord(VarPtr(r.v.val)) 
    463415    End Function 
    464416 
    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 
     417    Function ValError() As SCODE 
    472418        Dim r = ChangeType(VT_ERROR) 
    473419        Return GetDWord(VarPtr(r.v.val)) 
    474420    End Function 
    475421 
    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 
     422    Function ValCy() As Currency 
    483423        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      
     424        ValCy = Currency.FromCy(GetQWord(VarPtr(r.v.val))) 
     425    End Function 
     426 
    494427    'ValDate 
    495428 
    496     Const Function ValStr() As BString 
     429    Function ValStr() As BString 
    497430        ValStr = New BString 
    498431        Dim r As VARIANT 
    499         ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR) 
     432        changeType(r, VT_BSTR, VARIANT_ALPHABOOL) 
    500433        ValStr.Attach(GetPointer(VarPtr(r.val)) As BSTR) 
    501434    End Function 
    502435 
    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 
     436    Function ValUnknown() As IUnknown 
    514437        Dim r As VARIANT 
    515         ChangeType(r, 0, VT_UNKNOWN) 
     438        changeType(r, VT_UNKNOWN) 
    516439        Return _System_PtrUnknown(r.val As ULONG_PTR As VoidPtr) 
    517440    End Function 
    518441 
    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 
     442    Function ValObject() As VBObject 
    529443        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 */ 
     444        changeType(r, VT_DISPATCH) 
     445        ValObject = VBObject.Attach(_System_PtrUnknown(r.val As ULONG_PTR As VoidPtr) As IDispatch) 
     446    End Function 
     447 
    543448    'ValArray 
    544449 
    545     Const Function ValDecimal() As Decimal 
    546         Dim p = VarPtr(v) As *Decimal 
    547         Return New Deciaml(ByVal p) 
     450    Function ValDecimal() As Decimal 
     451        Dim p = VarPtr(v) As *DECIMAL 
     452        Return New Decimal(ByVal p) 
    548453    End Function 
    549454 
    … …  
    554459        v.vt = VT_DECIMAL '念の為 
    555460    End Sub 
    556      
    557461 
    558462    Function PtrToVariant() As *VARIANT 
    … …  
    562466    Static Function OptionalParam() As Variant 
    563467        If IsNothing(optionalParam) Then 
    564             Dim t = New Variant 
    565             t.ValError = DISP_E_PARAMNOTFOUND 
    566             InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0) 
     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 
    567477        End If 
    568478        Return optionalParam 
    … …  
    570480 
    571481    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) 
     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 
    577491        End If 
    578         Return optionalParam 
    579     End Function 
     492        Return null 
     493    End Function 
     494 
    580495Private 
    581496    v As VARIANT 
    … …  
    587502    Static Sub Move(ByRef dst As VARIANT, ByRef src As VARIANT) 
    588503        dst = src 
    589 '       src.vt = VT_EMPTY 
    590     End Sub 
    591  
    592     Static Function removeNull(v As Variant) As Varinat 
     504        src.vt = VT_EMPTY 
     505    End Sub 
     506 
     507    Static Function removeNull(v As Variant) As Variant 
    593508        If IsNothing(v) Then 
    594509            removeNull = Null 
    … …  
    600515    Static optionalParam = Nothing As Variant 
    601516    Static null = Nothing As Variant 
     517 
    602518End Class 
    603519 
    604 /* 
     520 
    605521Function Abs(v As Variant) As Variant 
    606522    Return v.Abs() 
    … …  
    618534    Return v.VarType() 
    619535End Function 
    620 */ 
     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 
    621608 
    622609End Namespace 'COM 

  • trunk/ab5.0/ablib/src/com/vbobject.ab

    r497 r709  
    66Namespace COM 
    77 
    8 Class VBObject 
     8Class VBObjectBase 
     9    Implements System.IDisposable, System.IEquatable<VBObjectBase> 
    910Public 
    10     Sub VBObject() 
    11         pdisp = 0 
    12     End Sub 
    13  
    14     Sub VBObject(className As String, pOuter As *IUnknown, clsContext As DWord) 
    15         VBObject(ToWCStr(className), pOuter, clsContext) 
    16     End Sub 
    17  
    18     Sub VBObject(className As PCSTR, pOuter As *IUnknown, clsContext As DWord) 
    19         VBObject(ToWCStr(className), pOuter, clsContext) 
    20     End Sub 
    21  
    22     Sub VBObject(className As PCWSTR, pOuter As *IUnknown, clsContext As DWord) 
    23         pdisp = 0 
    24         Dim clsid As CLSID 
    25         Dim hr = _System_CLSIDFromString(className, clsid) 
    26         VBObject(clsid, pOuter, clsContext) 
    27     End Sub 
    28  
    29     Sub VBObject(ByRef clsid As CLSID, pOuter As *IUnknown, clsContext As DWord) 
    30         Dim hr = CoCreateInstance(clsid, pOuter, clsContext, IID_IDispatch, pdisp) 
    31     End Sub 
    32  
    33     Sub VBObject(ByRef obj As VBObject) 
    34         pdisp = obj.pdisp 
    35         pdisp->AddRef() 
    36     End Sub 
    37  
    38     Sub ~VBObject() 
    39         Clear() 
     11    Sub VBObjectBase() 
     12        disp = Nothing 
     13    End Sub 
     14 
     15    Sub VBObjectBase(dispObj As IDispatch) 
     16        copy(disp, dispObj) 
     17    End Sub 
     18 
     19    Sub ~VBObjectBase() 
     20        Dispose() 
    4021    End Sub 
    4122 
    4223    Sub Clear() 
    43         If pdisp <> 0 Then 
    44             pdisp->Release() 
    45             pdisp = 0 
     24        Dispose() 
     25    End Sub 
     26 
     27    Virtual Sub Dispose() 
     28        If ObjPtr(disp) <> 0 Then 
     29            disp.Release() 
     30            disp = Nothing 
    4631        End If 
    4732    End Sub 
    4833 
    49     Function Operator [](name As PCWSTR) As DispatchCaller 
    50         Return GetCaller(name) 
    51     End Function 
    52  
    53     Function Operator [](name As String) As DispatchCaller 
    54         Return GetCaller(ToWCStr(name)) 
    55     End Function 
    56  
    57     Function Equals(y As VBObject) As Boolean 
    58         Return _System_COMReferenceEquals(pdisp, y.pdisp) 
     34'   Override Function Equals(y As Object) As Boolean 
     35'   End Function 
     36 
     37    Virtual Function Equals(y As VBObjectBase) As Boolean 
     38        Return Detail.COMReferenceEquals(This.Dispatch, y.Dispatch) 
    5939    End Function 
    6040/* 
    … …  
    6545    End Function 
    6646*/ 
    67     Function Operator ==(y As VBObject) As Boolean 
    68         Return Equals(y) 
    69     End Function 
    70  
    71     Function Operator <>(y As VBObject) As Boolean 
    72         Return Not Equals(y) 
    73     End Function 
    74  
    75     Sub Assign(p As *IDispatch) 
     47 
     48    Function Copy() As IDispatch 
     49        copy(Copy, disp) 
     50    End Function 
     51 
     52    Sub Attach(ByRef y As IDispatch) 
     53'       Clear() 
     54'       move(pdisp, y) 
     55    End Sub 
     56 
     57    Function Detach() As IDispatch 
     58        move(Detach, disp) 
     59    End Function 
     60 
     61    Function Dispatch() As IDispatch 
     62        Dispatch = disp 
     63    End Function 
     64Protected 
     65 
     66    Sub attach(ByRef y As IDispatch) 
    7667        Clear() 
    77         VBObject.Copy(pdisp, p) 
    78     End Sub 
    79  
    80     Function Copy() As *IDispatch 
    81         VBObject.Copy(GetDispatch, pdisp) 
    82     End Function 
    83  
    84     Sub Attach(ByRef p As *IDispatch) 
    85         Clear() 
    86         VBObject.Move(pdisp, p) 
    87     End Sub 
    88  
    89     Function Detach() As *IDispatch 
    90         VBObject.Move(Detach, pdisp) 
    91     End Function 
    92  
    93     Function Dispatch() As *IDispatch 
    94         Dispatch = pdisp 
    95     End Function 
     68        move(disp, y) 
     69    End Sub 
     70 
     71Private 
     72    disp As IDispatch 
     73 
     74    Static Sub copy(ByRef dst As IDispatch, ByVal src As IDispatch) 
     75        dst = src 
     76        If ObjPtr(src) <> 0 Then 
     77            src.AddRef() 
     78        End If 
     79    End Sub 
     80 
     81    Static Sub move(ByRef dst As IDispatch, ByRef src As IDispatch) 
     82        dst = src 
     83        src = Nothing 
     84    End Sub 
     85 
     86End Class 
     87 
     88Class VBObject 
     89    Inherits VBObjectBase 
     90Public 
     91    Static Function Attach(y As IDispatch) As VBObject 
     92        Attach = New VBObject 
     93        Attach.attach(y) 
     94    End Function 
     95 
     96    Sub VBObject() 
     97        disp = Nothing 
     98    End Sub 
     99 
     100    Sub VBObject(className As String, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord) 
     101        VBObjectBase(createInstance(className, outer, clsContext)) 
     102    End Sub 
     103 
     104    Sub VBObject(ByRef clsid As CLSID, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord) 
     105        VBObjectBase(createInstance(clsid, outer, clsContext)) 
     106    End Sub 
     107Private 
     108    Function createInstance(className As String, outer As IUnknown, clsContext As DWord) As IDispatch 
     109        Dim clsid = Detail.StringToCLSID(ToWCStr(className)) 
     110        createInstance = createInstance(clsid, outer, clsContext) 
     111    End Function 
     112 
     113    Function createInstance(ByRef clsid As CLSID, outer As IUnknown, clsContext As DWord) As IDispatch 
     114        Dim hr = CoCreateInstance(clsid, ObjPtr(outer), clsContext, IID_IDispatch, createInstance) 
     115        Windows.ThrowIfFailed(hr) 
     116    End Function 
     117Public 
     118 
     119    Function Operator [](name As PCWSTR) As DispatchCaller 
     120        Return GetCaller(name) 
     121    End Function 
     122 
     123    Function Operator [](name As String) As DispatchCaller 
     124        Return GetCaller(ToWCStr(name)) 
     125    End Function 
     126 
    96127Private 
    97128    Function GetCaller(name As PCWSTR) As DispatchCaller 
    98129        Dim dispid As DISPID 
    99         Dim hr = pdisp->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid)) 
    100         Return New DispatchCaller(pdisp, dispid) 
    101     End Function 
    102  
    103     pdisp As *IDispatch 
    104  
    105     Static Sub Copy(ByRef dst As *IDispatch, ByVal src As *IDispatch) 
    106         dst = src 
    107         dst->AddRef() 
    108     End Sub 
    109  
    110     Static Sub Move(ByRef dst As *IDispatch, ByRef src As *IDispatch) 
    111         dst = src 
    112         src = 0 
    113     End Sub 
     130        Dim hr = Dispatch.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid)) 
     131        Windows.ThrowIfFailed(hr) 
     132        Return New DispatchCaller(disp, dispid) 
     133    End Function 
    114134End Class 
    115135 
    116136Class DispatchCaller 
     137    Implements System.IDisposable 
    117138Public 
    118139    Sub DispatchCaller() 
    119140    End Sub 
    120     Sub DispatchCaller(pDispatch As *IDispatch, dispatchId As DISPID) 
    121         pdisp = pDispatch 
    122         pdisp->AddRef() 
     141    Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID) 
     142        disp = dispObj 
     143        disp.AddRef() 
    123144        dispid = dispatchId 
    124145    End Sub 
    125146 
    126     Sub DispatchCaller(ByRef dc As DispatchCaller) 
    127         pdisp = dc.pdisp 
    128         pdisp->AddRef() 
    129         dispid = dc.dispid 
    130     End Sub 
    131  
    132     Sub Operator =(ByRef dc As DispatchCaller) 
    133         Dispose() 
    134         DispatchCaller(dc) 
    135     End Sub 
    136  
    137147    Sub Dispose() 
    138         If pdisp <> 0 Then 
    139             pdisp->Release() 
    140             pdisp = 0 
     148        If ObjPtr(disp) <> NULL Then 
     149            disp.Release() 
     150            disp = Nothing 
    141151        End If 
    142152    End Sub 
    … …  
    154164            .cNamedArgs = 0 
    155165        End With 
    156         Dim ret As VARIANT 
    157         Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ret, 0, 0) 
    158         Dispose() 
    159         Prop = New Variant 
    160         v.Attach(ret) 
    161         Return v 
     166        Call = New Variant 
     167        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0) 
     168        Windows.ThrowIfFailed(hr) 
     169        Dispose() 
    162170    End Function 
    163171 
    … …  
    186194            .cNamedArgs = 0 
    187195        End With 
    188         Dim ret As VARIANT 
    189         Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0) 
    190         Dispose() 
    191         Dim v = New Variant 
    192         v.Attach(ret) 
    193         Return v 
     196        Call = New Variant 
     197        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0) 
     198        Windows.ThrowIfFailed(hr) 
     199        Dispose() 
    194200    End Function 
    195201 
    … …  
    259265            .cNamedArgs = 1 
    260266        End With 
    261         Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0) 
    262         Dispose() 
    263     End Sub 
    264  
    265  
    266     pdisp As *IDispatch 
     267        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0) 
     268        Windows.ThrowIfFailed(hr) 
     269        Dispose() 
     270    End Sub 
     271 
     272    disp As IDispatch 
    267273    dispid As DISPID 
    268274End Class 
    … …  
    276282End Function 
    277283 
    278 Function CallByName(obj As *IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant 
     284Function CallByName(obj As IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant 
    279285    Dim dispid As DISPID 
    280     Dim hr = obj->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid)) 
     286    Dim hr = obj.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid)) 
     287    Windows.ThrowIfFailed(hr) 
    281288    Dim dispParams As DISPPARAMS 
    282289    With dispParams 
    … …  
    286293        .cNamedArgs = 0 
    287294    End With 
    288     Dim ret As VARIANT 
    289     hr = obj->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0) 
    290295    CallByName = New Variant 
    291     CallByName.Attach(ret) 
    292     Return CallByName 
     296    hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0) 
     297    Windows.ThrowIfFailed(hr) 
    293298End Function 
    294299/* 
    … …  
    300305    Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL) 
    301306End Function 
    302 /* 
     307*/ 
    303308#ifdef _WIN32_DCOM 
    304309Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject 
    … …  
    306311    Dim si As COSERVERINFO 
    307312    Dim context As DWord 
    308     If /*Server = 0 OrElse* / Server[0] = 0 Then 
     313    If /*Server = 0 OrElse*/ Server[0] = 0 Then 
    309314        context = CLSCTX_SERVER 
    310315    Else 
    … …  
    332337End Function 
    333338#endif 
    334 */ 
    335 Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT 
     339 
     340 
     341Namespace Detail 
     342Function StringToCLSID(pwString As PCWSTR) As CLSID 
    336343    If pwString[0] = &h007b As WCHAR Then 
    337344        ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。 
    338         _System_CLSIDFromString = CLSIDFromString(pwString, guid) 
     345        Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID)) 
    339346    Else 
    340         _System_CLSIDFromString = CLSIDFromProgID(pwString, guid) 
    341     End If 
    342 End Function 
    343  
    344 Function _System_COMReferenceEquals(p As *IUnknown, q As *IUnknown) As Boolean 
    345     If p = q Then 
     347        Windows.ThrowIfFailed(CLSIDFromProgID(pwString, StringToCLSID)) 
     348    End If 
     349End Function 
     350 
     351Function COMReferenceEquals(p As IUnknown, q As IUnknown) As Boolean 
     352    If ObjPtr(p) = ObjPtr(q) Then 
    346353        Return True 
    347     Else If p = 0 Or q = 0 Then 
     354    Else If ObjPtr(p) = 0 Or ObjPtr(q) = 0 Then 
    348355        Return False 
    349356    End If 
    350357 
    351     Dim punkX = _System_GetUnknown(p) 
    352     Dim punkY = _System_GetUnknown(q) 
    353     If punkX = punkY Then 
    354         _System_COMReferenceEquals = True 
     358    Dim punkX = GetUnknown(p) 
     359    Dim punkY = GetUnknown(q) 
     360    If ObjPtr(punkX) = ObjPtr(punkY) Then 
     361        COMReferenceEquals = True 
    355362    Else 
    356         _System_COMReferenceEquals = False 
    357     End If 
    358     punkX->Release() 
    359     punkY->Release() 
    360 End Function 
    361  
    362 Function _System_GetUnknown(p As *IUnknown) As *IUnknown 'pは任意のCOMインタフェース 
    363     If FAILDED(pdisp->QueryInterface(IID_Unknown, _System_GetUnknown)) Then 
    364         GetUnknown = 0 
    365     End If 
    366 End Function 
     363        COMReferenceEquals = False 
     364    End If 
     365    punkX.Release() 
     366    punkY.Release() 
     367End Function 
     368 
     369Function GetUnknown(p As IUnknown) As IUnknown 'pは任意のCOMインタフェース 
     370    If FAILED(p.QueryInterface(IID_IUnknown, GetUnknown)) Then 
     371        GetUnknown = Nothing 
     372    End If 
     373End Function 
     374End Namespace 'Detail 
    367375 
    368376End Namespace 'COM 
Note: See TracChangeset for help on using the changeset viewer.