Changeset 709


Ignore:
Timestamp:
Jun 29, 2009, 4:03:45 AM (15 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.