超大整数的加减乘除运算及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