String Math Module (Big Integer Library) for VBA (Visual Basic for Applications)
I was recently working on an Access database for asset management for an IT department. Most of the computers they work with are Dells. Now a Dell has two numbers associated with it: an alphanumeric "service tag" and a plain numeric "express service code." Before this, I was working on a program to grab this information programmatically and generate a report. The service tag was easy, since it's the same as the serial number, which can be easily retrieved with WMIC. The express service code appeared to be harder, until I found out that the express service code is really just the serial number converted from base 36 to base 10! So this database contained two fields, for the serial number and the express service code, and I wanted to add a bit of functionality to it that would convert one to the other. The problem I quickly ran into is that VBA's Long type is only 32 bits wide - not enough to hold a serial number. I tried using Currency, but that would still overflow with any sufficiently long serial number (it was fine for Dell's 7-character serial numbers, but not Apple's 11-character serial numbers, for instance). I tried using Decimal, but VBA has no native support for Decimal, and I just couldn't get it to work. There is System.BigInteger, but that's only in .NET 4.0 and later. Finally I determined that the only way I could make this work is if I wrote a big number library myself. So here it is, string math for VBA:
Attribute VB_Name = "BigIntMath" Option Compare Database Private Type PartialDivideInfo Quotient As Integer Subtrahend As String Remainder As String End Type Private LastRemainder As String Private Const Alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" Public Function Compare(a As String, b As String) As Integer Dim an, bn, rn As Boolean Dim i, av, bv As Integer an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) If an And bn Then rn = True ElseIf bn Then Compare = 1 Exit Function ElseIf an Then Compare = -1 Exit Function Else rn = False End If Do While Len(a) > 1 And Left(a, 1) = "0" a = Mid(a, 2) Loop Do While Len(b) > 1 And Left(b, 1) = "0" b = Mid(b, 2) Loop If Len(a) < Len(b) Then Compare = -1 ElseIf Len(a) > Len(b) Then Compare = 1 Else Compare = 0 For i = 1 To Len(a) av = CInt(Mid(a, i, 1)) bv = CInt(Mid(b, i, 1)) If av < bv Then Compare = -1 Exit For ElseIf av > bv Then Compare = 1 Exit For End If Next i End If If rn Then Compare = -Compare End If End Function Public Function Add(a As String, b As String) As String Dim an, bn, rn As Boolean Dim ai, bi, carry As Integer an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) If an And bn Then rn = True ElseIf bn Then Add = Subtract(a, b) Exit Function ElseIf an Then Add = Subtract(b, a) Exit Function Else rn = False End If ai = Len(a) bi = Len(b) carry = 0 Add = "" Do While ai > 0 And bi > 0 carry = carry + CInt(Mid(a, ai, 1)) + CInt(Mid(b, bi, 1)) Add = CStr(carry Mod 10) + Add carry = carry \ 10 ai = ai - 1 bi = bi - 1 Loop Do While ai > 0 carry = carry + CInt(Mid(a, ai, 1)) Add = CStr(carry Mod 10) + Add carry = carry \ 10 ai = ai - 1 Loop Do While bi > 0 carry = carry + CInt(Mid(b, bi, 1)) Add = CStr(carry Mod 10) + Add carry = carry \ 10 bi = bi - 1 Loop Add = CStr(carry) + Add Do While Len(Add) > 1 And Left(Add, 1) = "0" Add = Mid(Add, 2) Loop If Add <> "0" And rn Then Add = "-" + Add End If End Function Private Function RealMod(a As Integer, b As Integer) As Integer If a Mod b = 0 Then RealMod = 0 ElseIf a < 0 Then RealMod = b + a Mod b Else RealMod = a Mod b End If End Function Private Function RealDiv(a As Integer, b As Integer) As Integer If a Mod b = 0 Then RealDiv = a \ b ElseIf a < 0 Then RealDiv = a \ b - 1 Else RealDiv = a \ b End If End Function Public Function Subtract(a As String, b As String) As String Dim an, bn, rn As Boolean Dim ai, bi, barrow As Integer an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) If an And bn Then rn = True ElseIf bn Then Subtract = Add(a, b) Exit Function ElseIf an Then Subtract = "-" + Add(a, b) Exit Function Else rn = False End If barrow = Compare(a, b) If barrow = 0 Then Subtract = "0" Exit Function ElseIf barrow < 0 Then Subtract = a a = b b = Subtract rn = Not rn End If ai = Len(a) bi = Len(b) barrow = 0 Subtract = "" Do While ai > 0 And bi > 0 barrow = barrow + CInt(Mid(a, ai, 1)) - CInt(Mid(b, bi, 1)) Subtract = CStr(RealMod(barrow, 10)) + Subtract barrow = RealDiv(barrow, 10) ai = ai - 1 bi = bi - 1 Loop Do While ai > 0 barrow = barrow + CInt(Mid(a, ai, 1)) Subtract = CStr(RealMod(barrow, 10)) + Subtract barrow = RealDiv(barrow, 10) ai = ai - 1 Loop Do While Len(Subtract) > 1 And Left(Subtract, 1) = "0" Subtract = Mid(Subtract, 2) Loop If Subtract <> "0" And rn Then Subtract = "-" + Subtract End If End Function Public Function Multiply(a As String, b As String) As String Dim an, bn, rn As Boolean Dim m() As Long Dim al, bl, ai, bi As Integer Dim carry As Long an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) rn = (an <> bn) al = Len(a) bl = Len(b) ReDim m(1 To (al + bl - 1)) For ai = 1 To al For bi = 1 To bl m(ai + bi - 1) = m(ai + bi - 1) + CLng(Mid(a, al - ai + 1, 1)) * CLng(Mid(b, bl - bi + 1, 1)) Next bi Next ai carry = 0 Multiply = "" For ai = 1 To al + bl - 1 carry = carry + m(ai) Multiply = CStr(carry Mod 10) + Multiply carry = carry \ 10 Next ai Multiply = CStr(carry) + Multiply Do While Len(Multiply) > 1 And Left(Multiply, 1) = "0" Multiply = Mid(Multiply, 2) Loop If Multiply <> "0" And rn Then Multiply = "-" + Multiply End If End Function Private Function PartialDivide(a As String, b As String) As PartialDivideInfo For PartialDivide.Quotient = 9 To 1 Step -1 PartialDivide.Subtrahend = Multiply(b, CStr(PartialDivide.Quotient)) If Compare(PartialDivide.Subtrahend, a) <= 0 Then PartialDivide.Remainder = Subtract(a, PartialDivide.Subtrahend) Exit Function End If Next PartialDivide.Quotient PartialDivide.Quotient = 0 PartialDivide.Subtrahend = "0" PartialDivide.Remainder = a End Function Public Function Divide(a As String, b As String) As String Dim an, bn, rn As Boolean Dim c As Integer Dim s As String Dim d As PartialDivideInfo an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) rn = (an <> bn) If Compare(b, "0") = 0 Then Err.Raise 11 Exit Function ElseIf Compare(a, "0") = 0 Then Divide = "0" LastRemainder = "0" Exit Function End If c = Compare(a, b) If c < 0 Then Divide = "0" LastRemainder = a Exit Function ElseIf c = 0 Then If rn Then Divide = "-1" Else Divide = "1" End If LastRemainder = "0" Exit Function End If Divide = "" s = "" For c = 1 To Len(a) s = s + Mid(a, c, 1) d = PartialDivide(s, b) Divide = Divide + CStr(d.Quotient) s = d.Remainder Next c Do While Len(Divide) > 1 And Left(Divide, 1) = "0" Divide = Mid(Divide, 2) Loop If Divide <> "0" And rn Then Divide = "-" + Divide End If LastRemainder = s End Function Public Function LastModulus() As String LastModulus = LastRemainder End Function Public Function Modulus(a As String, b As String) As String Divide a, b Modulus = LastRemainder End Function Public Function BigIntFromString(s As String, base As Integer) As String Dim rn As Boolean Dim bs As String Dim i, v As Integer If Left(s, 1) = "-" Then rn = True s = Mid(s, 2) Else rn = False End If bs = CStr(base) BigIntFromString = "0" For i = 1 To Len(s) v = InStr(Alphabet, UCase(Mid(s, i, 1))) If v > 0 Then BigIntFromString = Multiply(BigIntFromString, bs) BigIntFromString = Add(BigIntFromString, CStr(v - 1)) End If Next i If rn Then BigIntFromString = "-" + BigIntFromString End If End Function Public Function BigIntToString(s As String, base As Integer) As String Dim rn As Boolean Dim bs As String Dim v As Integer If Left(s, 1) = "-" Then rn = True s = Mid(s, 2) Else rn = False End If bs = CStr(base) BigIntToString = "" Do While Compare(s, "0") > 0 s = Divide(s, bs) v = CInt(LastModulus()) BigIntToString = Mid(Alphabet, v + 1, 1) + BigIntToString Loop If BigIntToString = "" Then BigIntToString = "0" ElseIf BigIntToString <> "0" And rn Then BigIntToString = "-" + BigIntToString End If End Function
A fair bit of warning, this doesn't do very extensive error checking to make sure the string inputs are in a valid format. That can easily be added, however. And it does check for division by zero, and throw a division by zero exception if that happens.
Attribute VB_Name = "BigIntMath" Option Compare Database Private Type PartialDivideInfo Quotient As Integer Subtrahend As String Remainder As String End Type Private LastRemainder As String Private Const Alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" Public Function Compare(a As String, b As String) As Integer Dim an, bn, rn As Boolean Dim i, av, bv As Integer an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) If an And bn Then rn = True ElseIf bn Then Compare = 1 Exit Function ElseIf an Then Compare = -1 Exit Function Else rn = False End If Do While Len(a) > 1 And Left(a, 1) = "0" a = Mid(a, 2) Loop Do While Len(b) > 1 And Left(b, 1) = "0" b = Mid(b, 2) Loop If Len(a) < Len(b) Then Compare = -1 ElseIf Len(a) > Len(b) Then Compare = 1 Else Compare = 0 For i = 1 To Len(a) av = CInt(Mid(a, i, 1)) bv = CInt(Mid(b, i, 1)) If av < bv Then Compare = -1 Exit For ElseIf av > bv Then Compare = 1 Exit For End If Next i End If If rn Then Compare = -Compare End If End Function Public Function Add(a As String, b As String) As String Dim an, bn, rn As Boolean Dim ai, bi, carry As Integer an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) If an And bn Then rn = True ElseIf bn Then Add = Subtract(a, b) Exit Function ElseIf an Then Add = Subtract(b, a) Exit Function Else rn = False End If ai = Len(a) bi = Len(b) carry = 0 Add = "" Do While ai > 0 And bi > 0 carry = carry + CInt(Mid(a, ai, 1)) + CInt(Mid(b, bi, 1)) Add = CStr(carry Mod 10) + Add carry = carry \ 10 ai = ai - 1 bi = bi - 1 Loop Do While ai > 0 carry = carry + CInt(Mid(a, ai, 1)) Add = CStr(carry Mod 10) + Add carry = carry \ 10 ai = ai - 1 Loop Do While bi > 0 carry = carry + CInt(Mid(b, bi, 1)) Add = CStr(carry Mod 10) + Add carry = carry \ 10 bi = bi - 1 Loop Add = CStr(carry) + Add Do While Len(Add) > 1 And Left(Add, 1) = "0" Add = Mid(Add, 2) Loop If Add <> "0" And rn Then Add = "-" + Add End If End Function Private Function RealMod(a As Integer, b As Integer) As Integer If a Mod b = 0 Then RealMod = 0 ElseIf a < 0 Then RealMod = b + a Mod b Else RealMod = a Mod b End If End Function Private Function RealDiv(a As Integer, b As Integer) As Integer If a Mod b = 0 Then RealDiv = a \ b ElseIf a < 0 Then RealDiv = a \ b - 1 Else RealDiv = a \ b End If End Function Public Function Subtract(a As String, b As String) As String Dim an, bn, rn As Boolean Dim ai, bi, barrow As Integer an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) If an And bn Then rn = True ElseIf bn Then Subtract = Add(a, b) Exit Function ElseIf an Then Subtract = "-" + Add(a, b) Exit Function Else rn = False End If barrow = Compare(a, b) If barrow = 0 Then Subtract = "0" Exit Function ElseIf barrow < 0 Then Subtract = a a = b b = Subtract rn = Not rn End If ai = Len(a) bi = Len(b) barrow = 0 Subtract = "" Do While ai > 0 And bi > 0 barrow = barrow + CInt(Mid(a, ai, 1)) - CInt(Mid(b, bi, 1)) Subtract = CStr(RealMod(barrow, 10)) + Subtract barrow = RealDiv(barrow, 10) ai = ai - 1 bi = bi - 1 Loop Do While ai > 0 barrow = barrow + CInt(Mid(a, ai, 1)) Subtract = CStr(RealMod(barrow, 10)) + Subtract barrow = RealDiv(barrow, 10) ai = ai - 1 Loop Do While Len(Subtract) > 1 And Left(Subtract, 1) = "0" Subtract = Mid(Subtract, 2) Loop If Subtract <> "0" And rn Then Subtract = "-" + Subtract End If End Function Public Function Multiply(a As String, b As String) As String Dim an, bn, rn As Boolean Dim m() As Long Dim al, bl, ai, bi As Integer Dim carry As Long an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) rn = (an <> bn) al = Len(a) bl = Len(b) ReDim m(1 To (al + bl - 1)) For ai = 1 To al For bi = 1 To bl m(ai + bi - 1) = m(ai + bi - 1) + CLng(Mid(a, al - ai + 1, 1)) * CLng(Mid(b, bl - bi + 1, 1)) Next bi Next ai carry = 0 Multiply = "" For ai = 1 To al + bl - 1 carry = carry + m(ai) Multiply = CStr(carry Mod 10) + Multiply carry = carry \ 10 Next ai Multiply = CStr(carry) + Multiply Do While Len(Multiply) > 1 And Left(Multiply, 1) = "0" Multiply = Mid(Multiply, 2) Loop If Multiply <> "0" And rn Then Multiply = "-" + Multiply End If End Function Private Function PartialDivide(a As String, b As String) As PartialDivideInfo For PartialDivide.Quotient = 9 To 1 Step -1 PartialDivide.Subtrahend = Multiply(b, CStr(PartialDivide.Quotient)) If Compare(PartialDivide.Subtrahend, a) <= 0 Then PartialDivide.Remainder = Subtract(a, PartialDivide.Subtrahend) Exit Function End If Next PartialDivide.Quotient PartialDivide.Quotient = 0 PartialDivide.Subtrahend = "0" PartialDivide.Remainder = a End Function Public Function Divide(a As String, b As String) As String Dim an, bn, rn As Boolean Dim c As Integer Dim s As String Dim d As PartialDivideInfo an = (Left(a, 1) = "-") bn = (Left(b, 1) = "-") If an Then a = Mid(a, 2) If bn Then b = Mid(b, 2) rn = (an <> bn) If Compare(b, "0") = 0 Then Err.Raise 11 Exit Function ElseIf Compare(a, "0") = 0 Then Divide = "0" LastRemainder = "0" Exit Function End If c = Compare(a, b) If c < 0 Then Divide = "0" LastRemainder = a Exit Function ElseIf c = 0 Then If rn Then Divide = "-1" Else Divide = "1" End If LastRemainder = "0" Exit Function End If Divide = "" s = "" For c = 1 To Len(a) s = s + Mid(a, c, 1) d = PartialDivide(s, b) Divide = Divide + CStr(d.Quotient) s = d.Remainder Next c Do While Len(Divide) > 1 And Left(Divide, 1) = "0" Divide = Mid(Divide, 2) Loop If Divide <> "0" And rn Then Divide = "-" + Divide End If LastRemainder = s End Function Public Function LastModulus() As String LastModulus = LastRemainder End Function Public Function Modulus(a As String, b As String) As String Divide a, b Modulus = LastRemainder End Function Public Function BigIntFromString(s As String, base As Integer) As String Dim rn As Boolean Dim bs As String Dim i, v As Integer If Left(s, 1) = "-" Then rn = True s = Mid(s, 2) Else rn = False End If bs = CStr(base) BigIntFromString = "0" For i = 1 To Len(s) v = InStr(Alphabet, UCase(Mid(s, i, 1))) If v > 0 Then BigIntFromString = Multiply(BigIntFromString, bs) BigIntFromString = Add(BigIntFromString, CStr(v - 1)) End If Next i If rn Then BigIntFromString = "-" + BigIntFromString End If End Function Public Function BigIntToString(s As String, base As Integer) As String Dim rn As Boolean Dim bs As String Dim v As Integer If Left(s, 1) = "-" Then rn = True s = Mid(s, 2) Else rn = False End If bs = CStr(base) BigIntToString = "" Do While Compare(s, "0") > 0 s = Divide(s, bs) v = CInt(LastModulus()) BigIntToString = Mid(Alphabet, v + 1, 1) + BigIntToString Loop If BigIntToString = "" Then BigIntToString = "0" ElseIf BigIntToString <> "0" And rn Then BigIntToString = "-" + BigIntToString End If End Function
A fair bit of warning, this doesn't do very extensive error checking to make sure the string inputs are in a valid format. That can easily be added, however. And it does check for division by zero, and throw a division by zero exception if that happens.