1  ' com/decimal.ab


2 


3  #require <com/variant.ab>


4  #require <com/currency.ab>


5 


6  Namespace ActiveBasic


7  Namespace COM


8 


9  Class Decimal


10  Implements System.ICloneable, System.IEquatable<Decimal>', System.IComparable<Decimal>


11  Public


12 


13  Sub Decimal()


14  End Sub


15 


16  Sub Decimal(d As Decimal)


17  dec = d.dec


18  End Sub


19 


20  Sub Decimal(ByRef d As DECIMAL)


21  dec = d


22  End Sub


23 


24  Sub Decimal(lo As Long, mid As Long, hi As Long, isNegative As Boolean, scale As Byte)


25  If scale > 28 Then


26  Throw New System.ArgumentOutOfRangeException("scale  Decimal constructor")


27  End If


28  Dim sign As Byte


29  If isNegative Then


30  sign = DECIMAL_NEG


31  Else


32  sign = 0


33  End If


34  dec.signscale = MAKEWORD(sign, scale) 'ToDo:どっちが上位だか検証すること


35  dec.Hi32 = hi


36  dec.Lo64 = MAKEQWORD(mid, lo)


37  End Sub


38 


39  Sub Decimal(x As Long)


40  Windows.ThrowIfFailed(VarDecFromI4(x, dec))


41  End Sub


42 


43  Sub Decimal(x As DWord)


44  Windows.ThrowIfFailed(VarDecFromUI4(x, dec))


45  End Sub


46 


47  Sub Decimal(x As Int64)


48  Windows.ThrowIfFailed(VarDecFromI8(x, dec))


49  End Sub


50 


51  Sub Decimal(x As QWord)


52  Windows.ThrowIfFailed(VarDecFromUI8(x, dec))


53  End Sub


54 


55  Sub Decimal(x As Single)


56  Windows.ThrowIfFailed(VarDecFromR4(x, dec))


57  End Sub


58 


59  Sub Decimal(x As Double)


60  Windows.ThrowIfFailed(VarDecFromR8(x, dec))


61  End Sub


62 


63  Const Function Operator() As Variant


64  Return New Variant(This)


65  End Function


66  /*


67  Static Function Operator(x As SByte) As Decimal


68  Dim d = New Decimal


69  VarDecFromI1(x, d.dec)


70  Return d


71  End Function


72 


73  Static Function Operator(x As Byte) As Decimal


74  Dim d = New Decimal


75  VarDecFromUI1(x, d.dec)


76  Return d


77  End Function


78 


79  Static Function Operator(x As Integer) As Decimal


80  Dim d = New Decimal


81  VarDecFromI2(x, d.dec)


82  Return d


83  End Function


84 


85  Static Function Operator(x As Word) As Decimal


86  Dim d = New Decimal


87  VarDecFromUI2(x, d.dec)


88  Return d


89  End Function


90 


91  Static Function Operator(x As Long) As Decimal


92  Dim d = New Decimal


93  VarDecFromI4(x, d.dec)


94  Return d


95  End Function


96 


97  Static Function Operator(x As DWord) As Decimal


98  Dim d = New Decimal


99  VarDecFromUI4(x, d.dec)


100  Return d


101  End Function


102 


103  Static Function Operator(x As Int64) As Decimal


104  Dim d = New Decimal


105  VarDecFromI8(x, d.dec)


106  Return d


107  End Function


108 


109  Static Function Operator(x As QWord) As Decimal


110  Dim d = New Decimal


111  VarDecFromUI8(x, d.dec)


112  Return d


113  End Function


114 


115  Static Function Operator(x As DECIMAL) As Decimal


116  Return New Decimal(X)


117  End Function


118 


119  Const Function Operator As() As SByte


120  Dim x As SByte


121  VarI1FromDec(dec, x)


122  Return x


123  End Function


124 


125  Const Function Operator As() As Byte


126  Dim x As Byte


127  VarUI1FromDec(dec, x)


128  Return x


129  End Function


130 


131  Const Function Operator As() As Integer


132  Dim x As Integer


133  VarI2FromDec(dec, x)


134  Return x


135  End Function


136 


137  Const Function Operator As() As Word


138  Dim x As Word


139  VarUI2FromDec(dec, x)


140  Return x


141  End Function


142 


143  Const Function Operator As() As Long


144  Dim x As Long


145  VarI4FromDec(dec, x)


146  Return x


147  End Function


148 


149  Const Function Operator As() As DWord


150  Dim x As DWord


151  VarUI4FromDec(dec, x)


152  Return x


153  End Function


154 


155  Const Function Operator As() As Int64


156  Dim x As Int64


157  VarI8FromDec(dec, x)


158  Return x


159  End Function


160 


161  Const Function Operator As() As QWord


162  Dim x As QWord


163  VarUI8FromDec(dec, x)


164  Return x


165  End Function


166 


167  Const Function Operator As() As Single


168  Dim x As Single


169  VarR4FromDec(dec, x)


170  Return x


171  End Function


172 


173  Const Function Operator As() As Double


174  Dim x As Double


175  VarR8FromDec(dec, x)


176  Return x


177  End Function


178 


179  Const Function Operator As() As Currency


180  Dim x As Currency


181  VarCyFromDec(dec, x)


182  Return x


183  End Function


184 


185  Const Function Operator As() As DECIMAL


186  Return dec


187  End Function


188 


189  Static Function Operator As(x As Single) As Decimal


190  Dim d = New Decimal


191  VarDecFromR4(x, d.dec)


192  Return d


193  End Function


194 


195  Static Function Operator As(x As Double) As Decimal


196  Dim d = New Decimal


197  VarDecFromR8(x, d.dec)


198  Return d


199  End Function


200  */


201 


202  Const Function Operator +() As Decimal


203  Return New Decimal(dec)


204  End Function


205 


206  Const Function Operator () As Decimal


207  Dim ret = New Decimal


208  Windows.ThrowIfFailed(VarDecNeg(This.dec, ret.dec))


209  Return ret


210  End Function


211 


212  Const Function Operator *(y As Decimal) As Decimal


213  Dim ret = New Decimal


214  Windows.ThrowIfFailed(VarDecMul(This.dec, y.dec, ret.dec))


215  Return ret


216  End Function


217 


218  Const Function Operator /(y As Decimal) As Decimal


219  Dim ret = New Decimal


220  Windows.ThrowIfFailed(VarDecDiv(This.dec, y.dec, ret.dec))


221  Return ret


222  End Function


223 


224  Const Function Operator +(y As Decimal) As Decimal


225  Dim ret = New Decimal


226  Windows.ThrowIfFailed(VarDecAdd(This.dec, y.dec, ret.dec))


227  Return ret


228  End Function


229 


230  Const Function Operator (y As Decimal) As Decimal


231  Dim ret = New Decimal


232  Windows.ThrowIfFailed(VarDecSub(This.dec, y.dec, ret.dec))


233  Return ret


234  End Function


235 


236  ' ThrowIfFailedしていないことに注意


237  Static Function Compare(x As Decimal, y As Decimal) As HRESULT


238  Compare = VarDecCmp(x.dec, y.dec)


239  End Function


240 


241  ' ThrowIfFailedしていないことに注意


242  Static Function Compare(x As Decimal, y As Double) As HRESULT


243  Return VarDecCmpR8(x.dec, y)


244  End Function


245 


246  Static Function Compare(x As Double, y As Decimal) As HRESULT


247  Dim ret = VarDecCmpR8(y.dec, x)


248  Select Case ret


249  Case VARCMP_LT


250  Return VARCMP_GT


251  Case VARCMP_GT


252  Return VARCMP_LT


253  Case Else


254  Return ret


255  End Select


256  End Function


257 


258  Const Function Operator ==(y As Decimal) As Boolean


259  Dim c = Compare(This, y)


260  Return c = VARCMP_EQ


261  End Function


262 


263  Const Function Operator ==(y As Double) As Boolean


264  Dim c = Compare(This, y)


265  Return c = VARCMP_EQ


266  End Function


267 


268  Const Function Operator <>(y As Decimal) As Boolean


269  Dim c = Compare(This, y)


270  Return c <> VARCMP_EQ


271  End Function


272 


273  Const Function Operator <>(y As Double) As Boolean


274  Dim c = Compare(This, y)


275  Return c <> VARCMP_EQ


276  End Function


277 


278  Const Function Operator <(y As Decimal) As Boolean


279  Dim c = Compare(This, y)


280  Return c = VARCMP_LT


281  End Function


282 


283  Const Function Operator <(y As Double) As Boolean


284  Dim c = Compare(This, y)


285  Return c = VARCMP_LT


286  End Function


287 


288  Const Function Operator >(y As Decimal) As Boolean


289  Dim c = Compare(This, y)


290  Return c = VARCMP_GT


291  End Function


292 


293  Const Function Operator >(y As Double) As Boolean


294  Dim c = Compare(This, y)


295  Return c = VARCMP_GT


296  End Function


297 


298  Const Function Operator <=(y As Decimal) As Boolean


299  Dim c = Compare(This, y)


300  Return c = VARCMP_LT Or c = VARCMP_EQ


301  End Function


302 


303  Const Function Operator <=(y As Double) As Boolean


304  Dim c = Compare(This, y)


305  Return c = VARCMP_LT Or c = VARCMP_EQ


306  End Function


307 


308  Const Function Operator >=(y As Decimal) As Boolean


309  Dim c = Compare(This, y)


310  Return c = VARCMP_GT Or c = VARCMP_EQ


311  End Function


312 


313  Const Function Operator >=(y As Double) As Boolean


314  Dim c = Compare(This, y)


315  Return c = VARCMP_GT Or c = VARCMP_EQ


316  End Function


317 


318  Const Function Abs() As Decimal


319  Abs = New Decimal


320  Windows.ThrowIfFailed(VarDecAbs(This.dec, Abs.dec))


321  End Function


322 


323  Const Function Fix() As Decimal


324  Fix = New Decimal


325  Windows.ThrowIfFailed(VarDecFix(This.dec, Fix.dec))


326  End Function


327 


328  Const Function Int() As Decimal


329  Int = New Decimal


330  Windows.ThrowIfFailed(VarDecInt(This.dec, Int.dec))


331  End Function


332 


333  Const Function Round(c = 0 As Long) As Decimal


334  Round = New Decimal


335  Windows.ThrowIfFailed(VarDecRound(This.dec, c, Round.dec))


336  End Function


337 


338  Const Function Dec() As DECIMAL


339  Return dec


340  End Function


341 


342  Const Function ToVariant() As Variant


343  Return New Variant(This)


344  End Function


345 


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 


353  Override Function ToString() As String


354  Using bstr = ToBString()


355  ToString = bstr.ToString


356  End Using


357  End Function


358 


359  Override Function GetHashCode() As Long


360  Dim p = VarPtr(dec) As *DWord


361  Return (p[0] Xor p[1] Xor p[2] Xor p[3]) As Long


362  End Function


363 


364  Function Equals(y As Decimal) As Boolean


365  Dim c = Compare(This, y)


366  Return c = VARCMP_EQ


367  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 


379  Private


380  dec As DECIMAL


381  End Class


382 


383  End Namespace 'COM


384  End Namespace 'ActiveBasic

