混合运算的代码

　　假如文本框有这样一个算式：3 * 7 - ((2 + 18)/5 + 6)，如何编写代码？
　　看起来是个很简单的式子，写起代码来却大费周章，耗费了我整整一天的时间。编程的思路最后归纳为：
　　1.整个算式当作字符串来处理，只是在具体计算时化为数值，结果再转为字符串
　　2.不断地用计算结果替换原单项计算式，例如用“21”替换“3 * 7”

　　解题步骤如下：

预备工作：
　　1.去掉字符串中的空格，上式就变成了这样的字符串：“3*7-((2+18)/5+6)”
　　2.将小写字母转换为大写字母

开始计算：
　　1.利用函数 FindPlace 查找括号的位置，取出括号及其中的算式作为一个子字符串。如上式中的“（2+18）”。
　　2.将去掉括号的算式（如果没有括号就将整个算式）交给 analyze 函数，按照乘、除、加减的顺序进行计算。
　　3.在进行单项计算时，先确定运算符的位置，以这个位置为基础，分别获取前后两个数据和运算符本身，如上式中的“2”、“18”、“+”。这个步骤中最麻烦的是对“-”号的处理，因为它既可表示减法，也可以表示负数。
　　4.根据运算符计算（这是最轻松的步骤了）
　　5.每进行完一次计算，都要将结果转换成字符串，去替换由数据和运算符组成的子字符串。如“20/5+6”，除完后，用商去替换“20/5”这个子字符串，得到一个新的字符串：“4+6”
　　6.重复步骤1-5，上式就依次变成：“3*7-10”、“21-10”、“11”，最后结果在Text2显示。

　　笔者根据以上叙述编写了代码。
　　本代码可以对2/8/16进制的数据进行运算（但计算结果均为10进制），这三种进制的输入规则是：在数据前加一个标识字母（大小写均可），字母B表示2进制，字母O表示8进制，字母H表示16进制，除了这三个字母和16进制数字 A－F，计算式中不能出现其它字母。
　　本代码还可以进行三角函数、对数、逻辑、角弧互换等运算

下面就动手实验：

　　新建一个窗体，添加两个文本框和一个按纽，其中Text1用于输入计算式，Text2用于显示计算结果。点击按纽就开始计算。

代码如下：

Option Explicit

Private Sub Text1_GotFocus()
Text1.SelStart = 0: Text1.SelLength = Len(Text1)
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Command1_Click
End Sub

Private Sub Command1_Click()
Dim st As String
st = Text1
st = Replace(st, vbCrLf, "")
st = UCase(StrConv(Replace(st, " ", ""), 8)) '去掉空格全角转半角再转为大写
st = Replace(st, "LOG", "S0S") '对数改名
st = Replace(st, "SIN", "S1S") '正弦改名
st = Replace(st, "COS", "S2S") '余弦改名
st = Replace(st, "TAN", "S3S") '正切改名
st = Replace(st, "CTG", "S4S") '余切改名
st = Replace(st, "ANG", "S5S") '角度改名
st = Replace(st, "RAD", "S6S") '弧度改名
st = Replace(st, "NOT", "L7L") '非改名
st = Replace(st, "AND", "L8L") '与改名
st = Replace(st, "OR", "L9L")  '或改名
st = Replace(st, "XOR", "LAL") '异或改名
st = Replace(st, "EQV", "LBL") '相符改名
st = Replace(st, "IMP", "LCL") '隐含改名
st = CheckString2(st): If InStr(st, "错误") Then MsgBox st: Exit Sub    '如果表达式有错误退出
st = CheckData(st, "H"): If InStr(st, "错误") Then MsgBox st: Exit Sub '如果数据有错误退出
st = CheckData(st, "O"): If InStr(st, "错误") Then MsgBox st: Exit Sub
st = CheckData(st, "B"): If InStr(st, "错误") Then MsgBox st: Exit Sub
Text2 = Operation(st)
End Sub

Private Function Operation(ByVal Dat1 As String) As String
Dim MyData1 As String, MyData2 As String, i As Integer, k As Integer

Do While InStr(Dat1, "(") > 0                          '如果有括号
  i = InStrRev(Dat1, "(")                              '查找最右边括号的位置
  MyData1 = Mid$(Dat1, i, InStr(i, Dat1, ")") + 1 - i) '取出括号及其中的算式
  MyData2 = Mid$(MyData1, 2, Len(MyData1) - 2)         '从取出的字符串中去掉左右括号
  MyData2 = analyze2(MyData2)                           '计算括号中的表达式
  Dat1 = Replace(Dat1, MyData1, MyData2)               '用计算结果替代原字符串中的括号内容
Loop

k = InStr(Dat1, ",") '逗号位置
If k Then
  MyData1 = Left(Dat1, k - 1) '截取逗号前的数据
  k = IIf(Len(Mid$(Dat1, k)) = 1, 16, Val(Mid$(Dat1, k + 1))) '如果逗号后无转换标识默认转为16进制
  Operation = 进制转换(MyData1, 10, k)
Else
  MyData1 = analyze2(Dat1)
  If InStr(MyData1, ".") Then MyData1 = Format(Round(MyData1, 4), "0.####")
  Operation = MyData1
End If
End Function

Private Function analyze2(ByVal Dat2 As String) As String
Dim i As Integer, z As String, nSt As String
nSt = Dat2
Do
  i = 0
  Do
    i = i + 1: z = Mid$(nSt, i, 3)
    If z = "S1S" Then nSt = AngRadCount(nSt, z): i = 0 '正弦
    If z = "S2S" Then nSt = AngRadCount(nSt, z): i = 0 '余弦
    If z = "S3S" Then nSt = AngRadCount(nSt, z): i = 0 '正切
    If z = "S4S" Then nSt = AngRadCount(nSt, z): i = 0 '余切
  Loop Until InStr(nSt, "S1S") = 0 And InStr(nSt, "S2S") = 0 And InStr(nSt, "S3S") = 0 And InStr(nSt, "S4S") = 0 Or i >= Len(nSt)
  i = 0
  Do
    i = i + 1: z = Mid$(nSt, i, 3)
    If z = "S5S" Then nSt = AngRadCount(nSt, z): i = 0 '角→弧
    If z = "S6S" Then nSt = AngRadCount(nSt, z): i = 0 '弧→角
  Loop Until InStr(nSt, "S5S") = 0 And InStr(nSt, "S6S") = 0 Or i >= Len(nSt)
 
  Do While InStr(nSt, "S0S"): nSt = AngRadCount(nSt, "S0S"): Loop '对数
  Do While InStr(nSt, "L7L"): nSt = AngRadCount(nSt, "L7L"): Loop '取反是单边运算
 
  Do While InStr(2, nSt, "L8L"): nSt = operate2(nSt, "L8L"): Loop '与
  Do While InStr(2, nSt, "L9L"): nSt = operate2(nSt, "L9L"): Loop '或
  Do While InStr(2, nSt, "LAL"): nSt = operate2(nSt, "LAL"): Loop '异或
  Do While InStr(2, nSt, "LBL"): nSt = operate2(nSt, "LBL"): Loop '相符
  Do While InStr(2, nSt, "LCL"): nSt = operate2(nSt, "LCL"): Loop '隐含
 
  Do While InStr(nSt, "^") > 0: nSt = operate2(nSt, "^"): Loop '乘方
  i = 1
  Do
    i = i + 1: z = Mid$(nSt, i, 1)
    If z = "*" Then nSt = operate2(nSt, z): i = 1 '乘法
    If z = "/" Then nSt = operate2(nSt, z): i = 1 '除法
  Loop Until InStr(2, nSt, "*") = 0 And InStr(2, nSt, "/") = 0 Or i >= Len(nSt)
  i = 1
  Do
    i = i + 1: z = Mid$(nSt, i, 1)
    If z = "+" Then nSt = operate2(nSt, z): i = 1 '加法
    If z = "-" Then nSt = operate2(nSt, z): i = 1 '减法
  Loop Until InStr(2, nSt, "+") = 0 And InStr(2, nSt, "-") = 0 Or i >= Len(nSt)
 
Loop While InStr(2, nSt, "^") Or InStr(2, nSt, "*") Or InStr(2, nSt, "/") Or InStr(2, nSt, "+") Or InStr(2, nSt, "-")
analyze2 = nSt
End Function

Private Function AngRadCount(ByVal Dat3 As String, Flags As String) As String '角弧对数三角函数
On Error GoTo 100
Dim z As String, num As Double, n As Double, i1 As Integer, i2 As Integer
Const p1 = 0.017453292
Const p2 = 3.1415926
z = Dat3
i1 = InStr(z, Flags)               'i1标识的起始位置
i2 = GetRearStr(z, Flags, 1)       'z包含标识后的数据字串，i2标识+数据字串的长度
If Len(z) = 0 Then Exit Function
If i1 = 2 Then i1 = 1: i2 = i2 + 1 '如果标识起始位置=2，那么前字符为无效，可将它替换掉
num = Val(z)

Select Case Flags
  Case "L7L": num = Not num
  Case "S0S": num = Log(num)
  Case "S5S": num = num / 180 * p2
  Case "S6S": num = num * 180 / p2
  Case "S1S": num = Sin(num * p1)
  Case "S2S": num = Cos(num * p1)
  Case "S3S": n = num / 90 + 1: If n / 2 <> n \ 2 Then num = Tan(num * p1) Else MsgBox "正切数据错误！"
  Case "S4S": num = 1 / (Tan(num * p1))
End Select
num = Round(num, 8)
AngRadCount = Replace(Dat3, Mid$(Dat3, i1, i2), Format(num)) '用计算后的字串替换原单项算式
100
End Function

Private Function operate2(ByVal Dat3 As String, sign As String) As String '逻辑运算和五则运算
Dim L As Integer, k1 As Integer, k2 As Integer, S1 As String, S2 As String, num As Double
S1 = Dat3: S2 = Dat3: L = IIf(InStr("+-*/^", sign), 2, 1)
k1 = GetFrontStr(S1, sign, L)          'S1：运算符前的数据，K1：运算式起始位置
k2 = GetRearStr(S2, sign, L) + Len(S1) 'S2：运算符后的数据，K2：运算式长度
If Len(S1) = 0 Or Len(S2) = 0 Then Exit Function

Select Case sign
  Case "L8L": num = Val(S1) And Val(S2)
  Case "L9L": num = Val(S1) Or Val(S2)
  Case "LAL": num = Val(S1) Xor Val(S2)
  Case "LBL": num = Val(S1) Eqv Val(S2)
  Case "LCL": num = Val(S1) Imp Val(S2)
  Case "+": num = Val(S1) + Val(S2)
  Case "-": num = Val(S1) - Val(S2)
  Case "*": num = Val(S1) * Val(S2)
  Case "/": If S2 <> "0" Then num = Val(S1) / Val(S2) Else MsgBox "除数不能为0！计算结果是错误的"
  Case "^": num = Val(S1) ^ Val(S2)
End Select
num = Round(num, 8)
operate2 = Replace(Dat3, Mid$(Dat3, k1, k2), Format(num)) '用计算后的字串替换原单项算式
End Function

Private Function GetFrontStr(mSt As String, Flags As String, L As Integer) As Integer '获取标识前的数据字串及起始位置
On Error GoTo 100
Dim i As Integer, k As Integer, z As String, n As String
i = InStr(L, mSt, Flags) '查找标识位置
z = Left$(mSt, i - 1)    '获得标识前的字符串
For k = Len(z) To 1 Step -1
  n = Mid$(z, k, 1): If k = 1 And n = "-" Then n = "." '如果是负数
  If InStr(".0123456789", n) = 0 Then Exit For
Next
k = k + 1
mSt = Mid$(z, k) '获得标识前的数据
GetFrontStr = k  '获得数据起始位置
100
End Function

Private Function GetRearStr(mSt As String, Flags As String, L As Integer) As Integer '获取标识后的数据字串及长度
Dim i As Integer, k As Integer, n As String
k = InStr(L, mSt, Flags) + Len(Flags) '查找标识后数据起始位置
For i = k To Len(mSt)                 '获取数据
  n = Mid$(mSt, i, 1): If i = k And n = "-" Then n = "." '如果是负数
  If InStr(".0123456789", n) = 0 Then Exit For
Next
mSt = Mid$(mSt, k, i - k)          '获得标识后的数据
GetRearStr = Len(mSt) + Len(Flags) '获得标识+后数据长度
End Function

Private Function CheckData(ByVal mSt As String, Flags As String) As String '判断数据是否合法
Dim i As Integer, j As Integer, k As Integer, L As Integer, z As String, z1 As String
j = InStr(mSt, Flags)       '查找进制标识所在的位置
Do While j > 0
  For i = j + 1 To Len(mSt) '获取数据
    If InStr("*/+-^(),SL", Mid$(mSt, i, 1)) Then Exit For
  Next
  z = Mid$(mSt, j + 1, i - j - 1): k = Len(z)
  Select Case Flags
    Case "O" '检查8进制数据
      If k > 11 Then
        z1 = "错误！8进制数据超过11位"
      Else
        For i = 1 To k
          If InStr(".01234567", Mid$(z, i, 1)) = 0 Then z1 = "错误！发现非法8进制数据：" & Mid$(z, i, 1): Exit For
        Next
      End If
      L = 8
    Case "B" '检查2进制数据
      If k > 32 Then
        z1 = "错误！2进制数据超过32位"
      Else
        For i = 1 To k
          If InStr(".01", Mid$(z, i, 1)) = 0 Then z1 = "错误！发现非法2进制数据：" & Mid$(z, i, 1): Exit For
        Next
      End If
      L = 2
    Case "H" '检查16进制数据
      If k > 8 Then
        z1 = "错误！16进制数据超过8位"
      Else
        For i = 1 To k
          If InStr(".0123456789ABCDEF", Mid$(z, i, 1)) = 0 Then z1 = "错误！发现非法16进制数据：" & Mid$(z, i, 1): Exit For
        Next
      End If
      L = 16
  End Select
  If Len(z1) Then j = 0 Else mSt = Replace(mSt, Mid$(mSt, j, k + 1), 进制转换(z, L, 10)): j = InStr(mSt, Flags) '如果没有错误就转换为10进制，并替换原2/8/16进制字符串
Loop
CheckData = IIf(Len(z1), z1, mSt)
End Function

'1.输入数据；2.输入数据进制；3.输出数据进制；4.结果保留的小数位
Private Function 进制转换(num As String, No1 As Integer, No2 As Integer, Optional retain As Integer = 8) As String
On Error GoTo ERR1
Dim a As Double, b As Double, Dat1 As Double, Dat2 As Double
Dim t1 As String, t2 As String, t3 As String, E As String
Dim i As Integer, k As Integer, L As Integer, j As Boolean
Dim bj1 As Boolean '小数标记
Dim bj2 As Boolean '负数标记

'检查输入数据
t1 = UCase(Replace(num, ",", ""))
If Left(t1, 1) = "-" Then t1 = Mid(t1, 2): bj2 = True '如果是负数
t2 = "."
For i = 48 To 57: t2 = t2 & Chr(i): Next
For i = 65 To 90: t2 = t2 & Chr(i): Next 't2=".0123456789ABCDEF"
t2 = Left(t2, No1 + 1): L = Len(t1)

For i = 1 To L
  If InStr(t2, Mid(t1, i, 1)) = 0 Then
    '警告:
    Exit Function '检查是否有无效数字
  End If
Next
t2 = "": k = InStr(t1, ".")

Select Case k
  Case 1          '纯小数
    t2 = Mid(t1, 2): t1 = "": GoSub 600
    bj1 = True
  Case 0, L       '纯整数
    If k = L Then t1 = Left(t1, k - 1)
    GoSub 500
  Case 2 To L - 1 '小数
    t2 = Mid(t1, k + 1): GoSub 600
    If Not j Then t1 = Left(t1, k - 1): GoSub 500
    bj1 = True
End Select
If j Then Exit Function '如果数字位超过

If No1 = 10 Then                      '如果输入的是10进制
  If Len(t1) Then Dat1 = Val(t1)
  If Len(t2) Then Dat2 = Val("." & t2)
Else                                  '其它进制转换为10进制
  If Len(t1) Then GoSub 100: Dat1 = b
  If Len(t2) Then GoSub 200: Dat2 = Round(b, retain)
End If

If No2 = 10 Then                      '如果输出的是10进制
  If bj2 Then                         '如果输入的是负数，求补码
    If Dat1 < 129 Then
      Dat1 = Dat1 - 128
    ElseIf Dat1 < 32769 Then
      Dat1 = Dat1 - 32768
    ElseIf Dat1 < 2147483649# Then
      Dat1 = Dat1 - 2147483649#
    End If
  End If
  进制转换 = Dat1 + Dat2
Else
  If bj2 Then                         '如果输入的是负数，求补码
    If bj1 Then Dat1 = Dat1 + 1: Dat2 = 1 - Dat2 '求小数部分的补码
    If Dat1 < 129 Then                           '求整数部分的补码
      Dat1 = IIf(Dat1 = 0, 128, 256 - Dat1)
    ElseIf Dat1 < 32769 Then
      Dat1 = 65536 - Dat1
    ElseIf Dat1 < 2147483649# Then
      Dat1 = 4294967296# - Dat1
    End If
  End If
  GoSub 300
  If Dat2 Then GoSub 400
  进制转换 = t1 & t2
End If

ERR1:
Exit Function

100 '整数部分转换为10进制
L = Len(t1)
For i = 0 To L - 1
  t3 = Mid(t1, L - i, 1)
  a = Asc(t3) - 48: If a > 9 Then a = a - 7
  b = b + a * No1 ^ i
Next
Return

200 '小数部分转换为10进制
L = Len(t2): b = 0
For i = 1 To L
  t3 = Mid(t2, i, 1)
  a = Asc(t3) - 48: If a > 9 Then a = a - 7
  b = b + a / No1 ^ i
Next
Return

300 '整数部分转换为其它进制
k = 0: t1 = ""
Do
  b = Int(Dat1 / No2): a = Dat1 - b * No2: Dat1 = b
  t1 = Chr(a + IIf(a > 9, 55, 48)) & t1
  k = k + 1: If Dat1 > 0 And (k Mod 4 = 0) Then t1 = "," & t1
Loop While Dat1 > 0
Return

400 '小数部分转换为其它进制
k = 0: t2 = IIf(t1 = "", "0.", ".")
Do
  a = Fix(No2 * Dat2): Dat2 = No2 * Dat2 - a
  If k > 0 And (k Mod 4 = 0) Then t2 = t2 & ","
  t2 = t2 & Chr(a + IIf(a > 9, 55, 48))
  k = k + 1
Loop Until Dat2 = 0 Or k = retain '保留小数位
Return

500 '检查整数部分的位数
L = Len(t1)
Select Case No1
  Case 10: j = L > 15
  Case 2: j = L > 50
  Case 8: j = L > 17
  Case 16: j = L > 13
End Select
Return

600 '检查小数部分的位数
j = Len(t2) > 8
Return
End Function

Private Function CheckString2(ByVal mSt As String) As String '判断计算式是否合法
Dim i As Integer
For i = 1 To Len(mSt)
  If InStr(".0123456789ABCDEFHLOS(),+-*/^", Mid$(mSt, i, 1)) = 0 Then: mSt = "错误！发现非法数据：" & Mid$(mSt, i, 1): GoTo endcheck
Next i
If UBound(Split(mSt, "(")) <> UBound(Split(mSt, ")")) Then mSt = "错误！表达式中括号不成对"
endcheck:
CheckString2 = mSt
End Function

　　OK，现在随便输入几个算式看看：

　　输入“b1010-((o2+18)/h5-h6)-o3*o7”，计算得：-9
　　输入“1010-hff*((o7-18)/ha-h6)/3*o7”，计算得：5234.5
　　输入“(hf*10*ha-b1010*50)/o31”，计算得：40
　　输入“SIN90",计算得：1

　　完全正确！

补充：
　　还有一种更为简单的办法（当然功能不如本代码多），代码如下：

Private Sub Command1_Click()
Dim OBJ As Object
Set OBJ = CreateObject("MSScriptControl.ScriptControl")'在工程中引用 Microsoft Script Control 1.0
OBJ.Language = "vbscript"  '定义内部脚本语言为 VBScript
Text2 = OBJ.eval_r(Text1)
Set OBJ = Nothing
End Sub

　　注意3点：
　　1.计算式中不能有二进制数据，以字母“B”打头也不行；
　　2.16进制和8进制标记前要加上英文字符“&”。例如：&ha-&h6+&010
　　3.如果计算结果≥H80000000，则以负数表示，HFFFFFFFF表示为-1