vb6计算器代码
VB6计算器
这是我年轻时候的一个作品，初衷是为了要处理超长数字的运算，8字节无符的那种，
可是咱VB没有那种类型不是，最长的double也只能处理8字节有符数，还是有精度损失的。
当时也不太懂，没办法，就编了这个计算器，用字符串做参数进行运算，运算效率低那是当然了，牺牲速度换取功能呗，贻笑大方啦。
现在明白了，其实，VB有Variant类型可以进行超长字符运算的，不信大家可以试试哦。
Dim Num As Variant
Dim highl As Variant
Dim lowl As Variant
Num = CDec(highl) * CDec(2 ^ 32) + CDec(lowl)
GetInt8Str = CStr(Num)
clsStringMath:
Option Explicit
'函数列表：
'
'
'字符加法 （jw=进位）
'Public Function CharAdd(s1 As String, s2 As String, jw As Boolean) As String
'例：?CharAdd("9","5",True)
' 15
'
'字符串加法
'Public Function StringAdd(s1 As String, s2 As String) As String
'例：?StringAdd("9999999", "2")
' 10000001
'
'字符减法 （minus=负号）
'Public Function CharSubtraction(s1 As String, s2 As String, ByRef minus As Boolean) As String
'例：?StringAdd("2", "3")
' 1，minus=true
'
'字符串减法 （minus=负号）
'Public Function StringSubtraction(ss1 As String, ss2 As String, minus As Boolean) As String
'例：?StringAdd("1234", "23423")
' 22189，minus=true
'
'字符乘法 （jw=进位）
'Public Function CharMultiple(s1 As String, s2 As String, jw As String) As String
'例：?CharMultiple("9", "9", "5")
' 86
'
'字符串乘法
'Public Function StringMultiple(s1 As String, s2 As String) As String
'例：?StringMultiple("156", "78")
' 12168
'
'字符除法
'Public Function CharDevide(s1 As String, s2 As String, ByRef ys As String) As String
'例：?CharDevide("19", "3",ys)
' 6,ys=1
'
'字符串除法
'Public Function StringDevide(s1 As String, s2 As String, ByRef ys As String) As String
'例：?StringDevide("156", "75", ys)
' 2,ys=6
'
'比较大小 ,s1>s2 =1,s1
'例：?StringBigger("156", "75")
' 1
'
'字符串指数
'Public Function StringIndex(X As String, IndexString As String) As String
'例：?StringIndex("16", "4")
' 65536
'
'十六进制转十进制
'Public Function StringFromHex(HexString As String) As String
'例：?StringFromHex("ffFFffFFffFFffFF")
' 18446744073709551615
'
'十六进制转字符数组'''''''''''''''''''''''
'Public Function HexStringToBuff(HexString As String, Buff() As Byte, ByRef BuffLen As String) As String
'例：?HexStringToBuff("155450",buff,bufflen)
' 100101111100111010,bufflen=3,buff(0)=2,buff(1)=95,buff(2)=58
'
'
'''加法'''''''''''''''''''''''
Public Function CharAdd(s1 As String, s2 As String, jw As Boolean) As String
Dim ss1 As String, ss2 As String, s As String
Dim l1 As Integer, l2 As Integer, l As Integer
Dim i As Integer
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
CharAdd = ""
Exit Function
End If
ss1 = Left(s1, 1)
ss2 = Left(s2, 1)
l1 = CInt(ss1)
l2 = CInt(ss2)
If jw = True Then
l = l1 + l2 + 1
Else
l = l1 + l2
End If
s = Format(l, "00")
CharAdd = s
End Function
Public Function StringAdd(s1 As String, s2 As String) As String
Dim l1 As Integer, l2 As Integer, l As Integer
Dim i As Integer, j As Integer
Dim s As String, ss As String
Dim jw As Boolean, oldjw As Boolean
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
StringAdd = ""
Exit Function
End If
l1 = Len(s1)
l2 = Len(s2)
If l2 > l1 Then
l = l2
For i = 1 To l - l1
s1 = "0" & s1
Next i
Else
l = l1
For i = 1 To l - l2
s2 = "0" & s2
Next i
End If
jw = False
For i = 0 To l - 1
j = l - i
s = CharAdd(Mid(s1, j, 1), Mid(s2, j, 1), jw)
If Left(s, 1) = 1 Then
jw = True
Else
jw = False
End If
ss = Right(s, 1) & ss
Next i
If jw = True Then
ss = "1" & ss
End If
StringAdd = ss
End Function
'''乘法'''''''''''''''''''''''
Public Function CharMultiple(s1 As String, s2 As String, jw As String) As String
Dim ss1 As String, ss2 As String, ss3 As String, s As String
Dim l1 As Integer, l2 As Integer, l3 As Integer, l As Integer
Dim i As Integer
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Or IsNumeric(jw) = False Then
CharMultiple = ""
Exit Function
End If
ss1 = Left(s1, 1)
ss2 = Left(s2, 1)
ss3 = Left(jw, 1)
l1 = CInt(ss1)
l2 = CInt(ss2)
l3 = CInt(ss3)
If l3 > 0 Then
l = l1 * l2 + l3
Else
l = l1 * l2
End If
s = Format(l, "00")
CharMultiple = s
End Function
Public Function StringMultiple(s1 As String, s2 As String) As String
Dim l1 As Integer, l2 As Integer, l As Integer
Dim i As Integer, j As Integer, ii As Integer, jj As Integer
Dim s As String, ss() As String, sss As String
Dim jw As String
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
StringMultiple = ""
Exit Function
End If
l1 = Len(s1)
l2 = Len(s2)
ReDim ss(1 To l2)
For j = 1 To l2
jw = "0"
For i = 1 To l1
ii = l1 - (i - 1)
jj = l2 - (j - 1)
s = CharMultiple(Mid(s1, ii, 1), Mid(s2, jj, 1), jw)
jw = Left(s, 1)
ss(j) = Right(s, 1) & ss(j)
Next i
If Left(s, 1) <> "0" Then
ss(j) = Left(s, 1) & ss(j)
End If
For i = 1 To j - 1
ss(j) = ss(j) & "0"
Next i
Next j
sss = "0"
For i = 1 To l2
sss = StringAdd(sss, ss(i))
Next i
StringMultiple = sss
End Function
'''指数'''''''''''''''''''''''
Public Function StringIndex(X As String, IndexString As String) As String
Dim l1 As Integer, i As Integer
Dim s As String
If X = "" Or IndexString = "" Or IsNumeric(X) = False Or IsNumeric(IndexString) = False Then
StringIndex = ""
Exit Function
End If
l1 = CInt(IndexString)
s = "1"
For i = 1 To l1
s = StringMultiple(s, X)
Next i
StringIndex = s
End Function
'''十六进制转十进制'''''''''''''''''''''''
Public Function StringFromHex(HexString As String) As String
Dim l1 As Integer, i As Integer, ii As Integer
Dim s1 As String, s2 As String, s As String
If HexString = "" Then
StringFromHex = ""
Exit Function
End If
l1 = Len(HexString)
s = "0"
For i = 1 To l1
ii = l1 - i + 1
s1 = Mid(HexString, ii, 1)
If UCase(s1) = "0" Then
s1 = "0"
ElseIf UCase(s1) = "1" Then
s1 = "1"
ElseIf UCase(s1) = "2" Then
s1 = "2"
ElseIf UCase(s1) = "3" Then
s1 = "3"
ElseIf UCase(s1) = "4" Then
s1 = "4"
ElseIf UCase(s1) = "5" Then
s1 = "5"
ElseIf UCase(s1) = "6" Then
s1 = "6"
ElseIf UCase(s1) = "7" Then
s1 = "7"
ElseIf UCase(s1) = "8" Then
s1 = "8"
ElseIf UCase(s1) = "9" Then
s1 = "9"
ElseIf UCase(s1) = "A" Then
s1 = "10"
ElseIf UCase(s1) = "B" Then
s1 = "11"
ElseIf UCase(s1) = "C" Then
s1 = "12"
ElseIf UCase(s1) = "D" Then
s1 = "13"
ElseIf UCase(s1) = "E" Then
s1 = "14"
ElseIf UCase(s1) = "F" Then
s1 = "15"
Else
s1 = "0"
End If
s2 = StringIndex("16", Format(i - 1, "0"))
s2 = StringMultiple(s1, s2)
s = StringAdd(s, s2)
Next i
StringFromHex = s
End Function
'''减法'''''''''''''''''''''''
Public Function CharSubtraction(s1 As String, s2 As String, ByRef minus As Boolean) As String
Dim ss1 As String, ss2 As String, s As String
Dim l1 As Integer, l2 As Integer, l As Integer
Dim i As Integer
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
CharSubtraction = ""
Exit Function
End If
ss1 = Left(s1, 2)
ss2 = Left(s2, 1)
l1 = CInt(ss1)
l2 = CInt(ss2)
If l1 < l2 Then
minus = True
Else
minus = False
End If
l = Abs(l1 - l2)
s = Format(l, "0")
CharSubtraction = s
End Function
Public Function StringSubtraction(ss1 As String, ss2 As String, minus As Boolean) As String
Dim l1 As Integer, l2 As Integer, l As Integer
Dim i As Integer, j As Integer
Dim s As String, ss As String, st As String
Dim s1 As String, s2 As String
Dim ms As Boolean, jw As Boolean, jw2 As Boolean
If ss1 = "" Or ss2 = "" Or IsNumeric(ss1) = False Or IsNumeric(ss2) = False Then
StringSubtraction = ""
Exit Function
End If
If StringBigger(ss1, ss2) <> "1" Then
s1 = ss2
s2 = ss1
Else
s1 = ss1
s2 = ss2
End If
l1 = Len(s1)
l2 = Len(s2)
If l2 > l1 Then
l = l2
For i = 1 To l - l1
s1 = "0" & s1
Next i
Else
l = l1
For i = 1 To l - l2
s2 = "0" & s2
Next i
End If
ms = False
jw = False
For i = 0 To l - 1
j = l - i
If jw = True Then
st = CharSubtraction(Mid(s1, j, 1), "1", jw)
If jw = True Then
st = CharSubtraction("1" & Mid(s1, j, 1), "1", jw2)
End If
Else
st = Mid(s1, j, 1)
End If
s = CharSubtraction(st, Mid(s2, j, 1), ms)
If ms = True Then
s = CharSubtraction("1" & st, Mid(s2, j, 1), ms)
jw = True
End If
ss = Right(s, 1) & ss
Next i
If jw = True Then
minus = True
End If
For i = 1 To Len(ss)
If Mid(ss, i, 1) <> "0" Then
Exit For
End If
Next i
If (i <> 1) And (ss <> "0") Then
s = Mid(ss, i, Len(ss) - i + 1)
Else
s = ss
End If
If StringBigger(ss1, ss2) = "-1" Then
minus = True
End If
StringSubtraction = s
End Function
'''除法'''''''''''''''''''''''
Public Function CharDevide(s1 As String, s2 As String, ByRef ys As String) As String
Dim ss1 As String, ss2 As String, sz As String, sy As String
Dim l1 As Integer, l2 As Integer, lz As Integer, ly As Integer, l As Integer
Dim i As Integer
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
CharDevide = ""
Exit Function
End If
ss1 = Left(s1, 1)
ss2 = Left(s2, 1)
l1 = CInt(ss1)
l2 = CInt(ss2)
lz = l1 \ l2
ly = l1 Mod l2
sz = Format(lz, "0")
sy = Format(ly, "0")
ys = sy
CharDevide = sz
End Function
Public Function StringDevide(s1 As String, s2 As String, ByRef ys As String) As String
Dim ss1 As String, ss2 As String, sz As String, sy As String
Dim l1 As Integer, l2 As Integer, lz As Inte
ger, ly As Integer, l As Integer
Dim i As String
Dim minus As Boolean
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
StringDevide = ""
Exit Function
End If
ys = "0"
ss1 = s1
ss2 = s2
i = "0"
Do While (StringBigger(ss2, ss1) = "-1") Or (StringBigger(ss2, ss1) = "0")
ss1 = StringSubtraction(ss1, ss2, minus)
i = StringAdd(i, "1")
Loop
sz = i
sy = ss1
ys = sy
StringDevide = sz
End Function
'''比较大小'''''''''''''''''''''''
Public Function StringBigger(s1 As String, s2 As String) As String
Dim ss1 As String, ss2 As String, sz As String, sy As String
Dim l1 As Integer, l2 As Integer, la As Integer, lb As Integer, l As Integer
Dim i As Integer
If s1 = "" Or s2 = "" Or IsNumeric(s1) = False Or IsNumeric(s2) = False Then
StringBigger = ""
Exit Function
End If
l1 = Len(s1)
l2 = Len(s2)
If l1 < l2 Then
StringBigger = "-1"
Exit Function
ElseIf l1 > l2 Then
StringBigger = "1"
Exit Function
End If
For i = 1 To l1
ss1 = Mid(s1, i, 1)
ss2 = Mid(s2, i, 1)
If ss1 <> ss2 Then
la = CInt(ss1)
lb = CInt(ss2)
If la < lb Then
StringBigger = "-1"
Else
StringBigger = "1"
End If
Exit Function
End If
Next i
StringBigger = "0"
End Function
'''十六进制转字符数组'''''''''''''''''''''''
Public Function HexStringToBuff(HexString As String, Buff() As Byte, ByRef BuffLen As String) As String
Dim s As String, sx As String, ys As String, yys As String
Dim l As Long, ll As Long, m As Long, i As Long, j As Long
If HexString = "" Then
HexStringToBuff = ""
Exit Function
End If
sx = HexString
ys = ""
yys = ""
Do While (sx <> "1")
sx = StringDevide(sx, "2", ys)
yys = ys & yys
Loop
yys = sx & yys
l = Len(yys)
If l Mod 8 = 0 Then
ll = l \ 8
Else
ll = l \ 8 + 1
End If
ReDim Buff(0 To ll - 1)
For i = 1 To l
j = l - i + 1
If Mid(yys, j, 1) = "1" Then
Buff(ll - (i \ 8) - 1) = Buff(ll - (i \ 8) - 1) Or (2 ^ ((i Mod 8) - 1))
Else
Buff(ll - (i \ 8) - 1) = Buff(ll - (i \ 8) - 1) And Not (2 ^ ((i Mod 8) - 1))
End If
Next i
BuffLen = ll
HexStringToBuff = yys
End Function
'''BCD码转数值'''''''''''''''''''''''
Public Function BCDStringToDbl(BCDString As String) As Double
Dim d As Double
If BCDString = "" Or IsNumeric(BCDString) = False Then
BCDStringToDbl = ""
Exit Function
End If
d = CDbl(BCDString)
BCDStringToDbl = d
End Function