|

楼主 |
发表于 2021-7-1 22:57
|
显示全部楼层
'超大整数的加减乘除运算及x进制转换
Option Explicit
Public Function IIf(ByVal blnExp, vtTrue, vtFalse)
If blnExp Then
IIf = vtTrue
Else
IIf = vtFalse
End If
End Function
Public Function ChangeType(vtData, vtType)
Dim ret
Select Case vtType
Case vbEmpty
Case vbNull
ret = Null
Case vbInteger
ret = ChangeType(vtData, vbDouble)
If ret >= -32768 And ret <= 32767 Then
ret = CInt(ret)
Else
ret = 0
End If
Case vbLong
ret = ChangeType(vtData, vbDouble)
If ret >= -2147483648 And ret <= 2147483647 Then
ret = CLng(ret)
Else
ret = CLng(0)
End If
Case vbSingle
If IsNumeric(vtData) Then
ret = CSng(vtData)
ElseIf VarType(vtData) = vbDecimal Then
ret = CSng(vtData)
Else
ret = CSng(0)
End If
Case vbDouble
If IsNumeric(vtData) Then
ret = CDbl(vtData)
ElseIf VarType(vtData) = vbDecimal Then
ret = CDbl(vtData)
Else
ret = CDbl(0)
End If
Case vbCurrency
ret = ChangeType(vtData, vbDouble)
If ret >= -922337203685477.5808 And ret <= 922337203685477.5807 Then
ret = CCur(ret)
Else
ret = CCur(0)
End If
Case vbDate
If IsDate(vtData) Then
ret = CDate(vtData)
End If
Case vbString
If Not IsNull(vtData) Then
ret = CStr(vtData)
Else
ret = Empty
End If
Case vbBoolean
ret = ChangeType(vtData, vbDouble)
ret = CBool(Not ret = 0)
Case vbByte
ret = ChangeType(vtData, vbDouble)
If ret >= 0 And ret <= 255 Then
ret = CByte(ret)
Else
ret = CByte(0)
End If
Case Else
If VarType(vtData) = vbObject Then
Set ret = vtData
Else
ret = vtData
End If
End Select
ChangeType = ret
End Function
Public Function atos(vtData)
atos = ChangeType(vtData, vbString)
End Function
Public Function atoi(vtData)
atoi = ChangeType(vtData, vbInteger)
End Function
Public Function atol(vtData)
atol = ChangeType(vtData, vbLong)
End Function
Public Function atof(vtData)
atof = ChangeType(vtData, vbDouble)
End Function
Class ImplNumber
Public Function MyFormat(ByVal n)
Dim p, r, l, i
p = atos(n)
l = Len(p)
ReDim r(l - 1)
For i = 1 To l
r(i - 1) = (Asc(Mid(p, i, 1)) And &HFF) - 48
If r(i - 1) < 0 Or r(i - 1) > 10 Then
Err.Raise vbObjectError + 1, "ImplNumber.Format", "第" & (i - 1) & "位字符(" & Chr(r(i - 1) + 48) & ")非数字"
End if
Next
MyFormat = r
End Function
Public Function MyFix(ByVal n)
Dim p
p = atos(n)
Do While Left(p, 1) = "0"
p = Mid(p, 2)
Loop
If p = "" Then p = "0"
MyFix = p
End Function
Private Function Compare(ByVal n1, ByVal n2)
Dim p1, p2
Dim l1, l2
Dim i, i1, i2
p1 = atos(n1)
p2 = atos(n2)
l1 = Len(p1)
l2 = Len(p2)
If l1 > l2 Then
Compare = 1
ElseIf l1 < l2 Then
Compare = -1
ElseIf p1 = p2 Then
Compare = 0
Else
For i = 1 To l1 Step 8
i1 = CLng(Mid(p1, i, 8))
i2 = CLng(Mid(p2, i, 8))
If i1 > i2 Then
Compare = 1
Exit For
ElseIf i1 < i2 Then
Compare = -1
Exit For
End If
Next
End If
End Function
Private Function MyNumber(ByVal l)
Dim r, i
ReDim r(l)
For i = 0 To l
r(i) = 0
Next
MyNumber = r
End Function
Private Function MyAdd(ByVal n1, ByVal n2)
Dim p1, p2, p3
Dim l1, l2, l3
Dim i, t
p1 = MyFormat(n1)
p2 = MyFormat(n2)
l1 = UBound(p1)
l2 = UBound(p2)
l3 = IIf(l1 > l2, l1, l2) + 1
p3 = MyNumber(l3)
t = 0
For i = 0 To l3
If l1 - i >= 0 Then t = t + p1(l1 - i)
If l2 - i >= 0 Then t = t + p2(l2 - i)
p3(l3 - i) = IIf(t > 9, t - 10, t)
t = IIf(t > 9, 1, 0)
Next
MyAdd = MyFix(Join(p3, ""))
Erase p1
Erase p2
Erase p3
End Function
Private Function MySubtract(ByVal n1, ByVal n2)
Dim p1, p2, p3, sign
Dim i, t, l1, l2, l3
Select Case Compare(n1, n2)
Case -1
p1 = MyFormat(n2)
p2 = MyFormat(n1)
sign = "-"
Case 0
MySubtract = "0"
Exit Function
Case 1
p1 = MyFormat(n1)
p2 = MyFormat(n2)
End Select
l1 = UBound(p1)
l2 = UBound(p2)
l3 = l1
p3 = MyNumber(l3)
t = 0
For i = 0 To l3
If l1 - i >= 0 Then t = p1(l1 - i) - t
If l2 - i >= 0 Then t = t - p2(l2 - i)
p3(l3 - i) = IIf(t < 0, t + 10, t)
t = IIf(t < 0, 1, 0)
Next
MySubtract = sign & MyFix(Join(p3, ""))
Erase p1
Erase p2
Erase p3
End Function
'加法
Public Function Add(ByVal n1, ByVal n2)
Dim s1, s2
Dim p1, p2
p1 = MyFix(n1)
p2 = MyFix(n2)
s1 = Left(p1, 1)
s2 = Left(p2, 1)
If s1 = "-" Then p1 = MyFix(Mid(p1, 2))
If s2 = "-" Then p2 = MyFix(Mid(p2, 2))
If s1 = "-" Then
If s2 = "-" Then
Add = "-" & MyAdd(p1, p2)
Else
Add = MySubstract(p2, p1)
End If
Else
If s2 = "-" Then
Add = MySubtract(p1, p2)
Else
Add = MyAdd(p1, p2)
End If
End If
End Function
'减法
Public Function Subtract(ByVal n1, ByVal n2)
Dim s1, s2
Dim p1, p2
p1 = MyFix(n1)
p2 = MyFix(n2)
s1 = Left(p1, 1)
s2 = Left(p2, 1)
If s1 = "-" Then p1 = MyFix(Mid(p1, 2))
If s2 = "-" Then p2 = MyFix(Mid(p2, 2))
If s1 = "-" Then
If s2 = "-" Then
Subtract = MySubstract(p2, p1)
Else
Subtract = "-" & MyAdd(p1, p2)
End If
Else
If s2 = "-" Then
Subtract = MyAdd(p1, p2)
Else
Subtract = MySubtract(p1, p2)
End If
End If
End Function
Private Function MyMultiply(ByVal n1, ByVal n2)
Dim p1, p2, p3, p4
Dim l1, l2, l3
Dim i, k, t
If Compare(n1, n2) = 1 Then
p1 = MyFormat(n2)
p2 = MyFormat(n1)
Else
p1 = MyFormat(n1)
p2 = MyFormat(n2)
End If
l1 = UBound(p1)
l2 = UBound(p2)
p4 = "0"
For i = 0 To l1
l3 = l2 + i + 1
p3 = MyNumber(l3)
t = 0
For k = 0 To l2
t = t + p1(l1 - i) * p2(l2 - k)
p3(l3 - i - k) = IIf(t > 9, (t Mod 10), t)
t = IIf(t > 9, t / 10, 0)
Next
If t > 0 Then
p3(l3 - i - k) = t
End If
p4 = MyAdd(p4, MyFix(Join(p3, "")))
Erase p3
Next
MyMultiply = p4
Erase p1
Erase p2
End Function
'乘法
Public Function Multiply(ByVal n1, ByVal n2)
Dim s1, s2
Dim p1, p2
p1 = MyFix(n1)
p2 = MyFix(n2)
s1 = Left(p1, 1)
s2 = Left(p2, 1)
If s1 = "-" Then p1 = MyFix(Mid(p1, 2))
If s2 = "-" Then p2 = MyFix(Mid(p2, 2))
If p1 = "0" Or p2 = "0" Then
Multiply = "0"
ElseIf s1 = "-" Then
If s2 = "-" Then
Multiply = MyMultiply(p1, p2)
Else
Multiply = "-" & MyMultiply(p1, p2)
End If
Else
If s2 = "-" Then
Multiply = "-" & MyMultiply(p1, p2)
Else
Multiply = MyMultiply(p1, p2)
End If
End If
End Function
Private Function MyDiv(ByVal n1, ByVal n2)
Dim p(1), n3, i
n3 = MySubtract(n1, n2)
i = 1
Do While Compare(n3, n2) <> -1
n3 = MySubtract(n3, n2)
i = i + 1
Loop
p(0) = i
p(1) = n3
MyDiv = p
End Function
Private Function MyDivision(ByVal n1, ByVal n2, ByVal decimal, ByVal sign)
Dim p1, p2, p3(1), p4, p5
Dim i, cmp, l1, l2, lx
If decimal > 0 Then
p1 = n1 & String(decimal, "0")
Else
p1 = n1
End If
p2 = n2
cmp = Compare(p1, p2)
If cmp = -1 Then
p3(0) = 0
p3(1) = n1
MyDivision = p3
Exit Function
End If
If cmp = 0 Then
If decimal > 0 Then
p3(0) = sign & "0." & String(decimal - 1, "0") & 1
p3(1) = n1
Else
p3(0) = sign & "1"
p3(1) = 0
End If
MyDivision = p3
Exit Function
End If
l1 = Len(p1)
l2 = Len(p2)
lx = Len(n1)
p4 = Mid(p1, 1, l2)
i = l2
p3(0) = sign
If decimal > 0 And i > lx Then
p3(0) = p3(0) & "." & String(i - lx - 1, "0")
End If
Do While i <= l1
If Compare(p4, p2) <> -1 Then
p5 = MyDiv(p4, p2)
p4 = p5(1)
p3(0) = p3(0) & p5(0)
ElseIf i = l1 Then
If i = lx Then p3(1) = MyFix(p4)
Exit Do
Else
If i = lx Then
p3(1) = MyFix(p4)
If decimal > 0 Then p3(0) = p3(0) & "."
End If
i = i + 1
p4 = MyFix(p4 & Mid(p1, i, 1))
If Compare(p4, p2) = -1 Then p3(0) = p3(0) & "0"
End If
Loop
MyDivision = p3
End Function
'除法
'decimal = 小数点后的位数
'函数返回拥有两个元素的数组
'元素0 = 商
'元素1 = 余数
Public Function Division(ByVal n1, ByVal n2, ByVal decimal)
Dim s1, s2
Dim p1, p2
p1 = MyFix(n1)
p2 = MyFix(n2)
s1 = Left(p1, 1)
s2 = Left(p2, 1)
If s1 = "-" Then p1 = MyFix(Mid(p1, 2))
If s2 = "-" Then p2 = MyFix(Mid(p2, 2))
If p1 = "0" Then
Division = Array(0, 0)
ElseIf p2 = "0" Then
Err.Raise vbObjectError + 1, "ImplNumber.Division", "被零除"
ElseIf s1 = "-" Then
If s2 = "-" Then
Division = MyDivision(p1, p2, decimal, "")
Else
Division = MyDivision(p1, p2, decimal, "-")
End If
Else
If s2 = "-" Then
Division = MyDivision(p1, p2, decimal, "-")
Else
Division = MyDivision(p1, p2, decimal, "")
End If
End If
End Function
'将一个10进制整数进行(2 - 36)进制的转换
Public Function BaseX(ByVal n, ByVal x)
Dim s, i, p
If x < 2 Then
Err.Raise vbObjectError + 1, "ImplNumber.BaseX", "错误的进制"
End If
If Compare(n, "0") = 1 Then
p = Division(n, x, 0)
s = s & BaseX(p(0), x)
i = CInt(p(1))
If i < 10 Then
s = s & i
Else
s = s & Chr(i + 55)
End If
End If
BaseX = s
End Function
'将一个(2 - 36)进制的字符转换成10进制的整数
Public Function ConvertX(ByVal s, ByVal x)
Dim i
Dim n, p, t
If x < 2 Then
Err.Raise vbObjectError + 1, "ImplNumber.ConvertX", "错误的进制"
End If
n = 0
p = 1
For i = Len(s) To 1 Step -1
t = Asc(Mid(s, i, 1)) And &HFF
If t >= 48 And t <= 57 Then
t = t - 48
ElseIf t >= 65 And t < 55 + x And t <= 90 Then
t = t - 55
ElseIf t >= 97 And t < 87 + x And t <= 122 Then
t = t - 87
Else
Err.Raise vbObjectError + 1, "ImplNumber.ConvertX", "错误的进制字符串"
End If
n = Add(n, Multiply(t, p))
p = Multiply(p, x)
Next
ConvertX = n
End Function
End Class
'范例
Dim num, i, x
Set num = New ImplNumber
WScript.Echo num.Add(784921795923989, 5215632421426)
WScript.Echo num.Subtract(784921795923989, 5215632421426)
WScript.Echo num.Multiply(784921795923989, 5215632421426)
WScript.Echo Join(num.Division(784921795923989, 5215632421426, 12), " - ")
For i = 2 To 36
x = num.BaseX(784921795923989, i)
WScript.Echo "Base" & i & "(" & num.ConvertX(x, i) & ") = " & x
Next
Set num = Nothing |
|