功能强大的表达式计算函数(模块)

'功能强大的表达式计算模块
'作者：董凯颂
'作者单位：安徽省安庆市花凉亭灌区管理局
'电子信箱:[e-mail]
'Web site:http://hexun.com/headbegger/
'2005年9月10日
'鄙视匿名抄袭和剽切,转载或传播、修改发布时请注明软件原作者

'******************************计算用户输入的表达式******************************************************
'********************************************************************************************************
'*支持+、-、*、/、^、()、常用函数，函数书写不分大小写,中间允许有空格,但参数表达式必须放在括号内         *
'*支持的函数包括：sin()正弦、cos()余弦、tan()正切、asin()反正弦、acos()反余弦、atn()反正切、ln()自然对数*
'*log()以10为底的常用对数、exp()e的幂、jch()自然数阶乘、sqr()平方根、int()取整、pi常数π                *
'*因为排错功能有限，使用时，请正确输入算式。三角函数的参数单位为弧度,使用函数时注意函数的定义域         *
'********************************************************************************************************


Const pi As String = "3.14159265358979"


'（两个大数之积）,为下面定义阶函数乘用
Private Function multi(ByVal x As String, ByVal Y As String) As String
    Dim result As Variant
    Dim xl As Long, yl As Long, temp As Long, i As Long
    xl = Len(Trim(x))
    yl = Len(Trim(Y))
    ReDim result(1 To xl + yl) '重定义数组，因为后面用Erase清空了数组
    For i = 1 To xl
        For temp = 1 To yl
            result(i + temp) = result(i + temp) + Val(Mid(x, i, 1)) * Val(Mid(Y, temp, 1))
            DoEvents
        Next
    Next
    For i = xl + yl To 2 Step -1
        temp = result(i) \ 10 'temp定义为整型，它只取 result(i) \ 10的整数部分
        result(i) = result(i) Mod 10
        result(i - 1) = result(i - 1) + temp '把进位的数加在高位上
    Next
    If result(1) = "0" Then result(1) = ""
        multi = Join(result, "") 'join函数把result数组里的元数连接起来
    Erase result '清空数组
End Function

'定义阶乘n! ,n为正整数,
Private Function JCh(ByVal x As String) As String
    Dim a() As String, i As Long, n As Long
'    小数自动取整,负数取正
    n = Val(x):  n = Abs(n):  n = Int(n)
    If n = 0 Then
        JCh = 1
        Exit Function
    End If
    ReDim a(1 To n)
    a(1) = 1
    For i = 2 To n
        a(i) = multi(a(i - 1), i)
    Next
    JCh = CStr(a(n))
End Function

Private Function Asin(xx As String) As String   '定义反正弦函数
    Dim x As Double
    If Not IsNumeric(xx) Then Exit Function
    x = Val(xx)
    If Abs(x) > 1 Then
        MsgBox "无效的参数。", vbOKOnly + vbExclamation, "错误!"
        Exit Function
    End If
    Asin = CStr(Atn(x / Sqr(1 - x * x)))
End Function

Private Function Acos(xx As String) As String  '定义反余弦函数
    Dim x As Double
    If Not IsNumeric(xx) Then Exit Function
    x = Val(xx)
    If Abs(x) > 1 Then
        MsgBox "无效的参数。", vbOKOnly + vbExclamation, "错误!"
        Exit Function
    End If
    Acos = CStr(Val(pi) / 2 - Val(Asin(xx)))
End Function

' 取出一个字符
' 参数： Str1 处理的字符串
' 返回： 字符串的第一个字符
'        Str1 成为被取后的字符串
Private Function ReadChar(Str1 As String) As String
  ReadChar = ""
  If Str1 = "" Then Exit Function
  ReadChar = Left(Str1, 1)
  Str1 = Right(Str1, Len(Str1) - 1)
End Function

' 退回一个字符
' 参数： Str1 处理的字符串
'        AChar 要退回的字符
' 返回： Str1 ：被退回后的字符串
Private Function RetChar(Str1 As String, AChar As String) As String
  Str1 = AChar & Str1
  RetChar = Str1
End Function
'
'检查字符串的合法性***************************************
Private Function CheckString(Str1 As String) As String
    On Error Resume Next
   Dim C1 As String
   '检查是否为空
   If Str1 = "" Then
      Exit Function
   End If
                                            
   '去掉所有空格
   Str1 = Replace(Str1, " ", "")
   '检查非法书写错误
   C1 = Left(Str1, 1)
   If C1 = "+" Or C1 = "*" Or C1 = "/" Or C1 = ")" Then
        MsgBox "计算式错误。", vbOKOnly + vbExclamation, "错误!"
        Exit Function
   End If
   C1 = Right(Str1, 1)
      If C1 = "+" Or C1 = "*" Or C1 = "/" Or C1 = "(" Or C1 = "-" Then
        MsgBox "计算式错误。", vbOKOnly + vbExclamation, "错误!"
        Exit Function
   End If
   '检查该字符串中是否有非法字符
   '检查的方法是将所有合法字符全部替换成空
   '替换完后如果该字符串中还有字符，则说明包含非法字符
   Dim StrTemp As String
   StrTemp = UCase(Str1)
   StrTemp = Replace(StrTemp, "SIN", "")  '正弦
   StrTemp = Replace(StrTemp, "COS", "")  '余弦
   StrTemp = Replace(StrTemp, "LOG", "")  '常用对数
   StrTemp = Replace(StrTemp, "EXP", "")  '常数e为底的幂
   StrTemp = Replace(StrTemp, "JCH", "")  '阶乘
   StrTemp = Replace(StrTemp, "TAN", "")  '正切
   StrTemp = Replace(StrTemp, "ASIN", "") '反正弦
   StrTemp = Replace(StrTemp, "ACOS", "") '反余弦
   StrTemp = Replace(StrTemp, "ATN", "")  '反正切
   StrTemp = Replace(StrTemp, "LN", "")   '自然对数
   StrTemp = Replace(StrTemp, "PI", "")   '常数π
   StrTemp = Replace(StrTemp, "INT", "")  '取整
   StrTemp = Replace(StrTemp, "SQR", "")  '平方根
   StrTemp = Replace(StrTemp, "+", "")
   StrTemp = Replace(StrTemp, "-", "")
   StrTemp = Replace(StrTemp, "*", "")
   StrTemp = Replace(StrTemp, "/", "")
   StrTemp = Replace(StrTemp, "^", "")    '幂
   StrTemp = Replace(StrTemp, "0", "")
   StrTemp = Replace(StrTemp, "1", "")
   StrTemp = Replace(StrTemp, "2", "")
   StrTemp = Replace(StrTemp, "3", "")
   StrTemp = Replace(StrTemp, "4", "")
   StrTemp = Replace(StrTemp, "5", "")
   StrTemp = Replace(StrTemp, "6", "")
   StrTemp = Replace(StrTemp, "7", "")
   StrTemp = Replace(StrTemp, "8", "")
   StrTemp = Replace(StrTemp, "9", "")
   StrTemp = Replace(StrTemp, "(", "")
   StrTemp = Replace(StrTemp, ")", "")
   StrTemp = Replace(StrTemp, ".", "")
   If StrTemp <> "" Then
      MsgBox "计算式错误或包含有非法字符。", vbOKOnly + vbExclamation, "错误!"
      Exit Function
   End If
  
   '检查括号是否匹配,括号位置、运算符位置是否有错误
   Dim i As Integer, s1 As Integer, s2 As Integer
   StrTemp = Str1
   C1 = ReadChar(StrTemp)
   i = i + 1
   Do While C1 <> ""
        Select Case C1
        Case "("
            If Mid(Str1, i + 1, 1) = "." Or Mid(Str1, i + 1, 1) = ")" Or Mid(Str1, i + 1, 1) = "+" _
               Or Mid(Str1, i + 1, 1) = "*" Or Mid(Str1, i + 1, 1) = "/" Or Mid(Str1, i + 1, 1) = "^" Then
                MsgBox "计算式错误。", vbOKOnly + vbExclamation, "错误!"
                 Exit Function
            ElseIf i > 1 Then
                    If IsNumeric(Mid(Str1, i - 1, 1)) Or Mid(Str1, i - 1, 1) = ")" Or Mid(Str1, i - 1, 1) = "." Then
                        MsgBox "计算式错误。", vbOKOnly + vbExclamation, "错误!"
                        Exit Function
                    End If
            End If
            s1 = s1 + 1
            If s1 < s2 Then
                 MsgBox "括号不匹配或计算式错误。", vbOKOnly + vbExclamation, "错误!"
                 Exit Function
            End If
        Case ")"
            If (IsNumeric(Mid(Str1, i - 1, 1)) Or Mid(Str1, i - 1, 1) = ")") And (Mid(Str1, i + 1, 1) = ")" Or Mid(Str1, i + 1, 1) = "+" _
               Or Mid(Str1, i + 1, 1) = "*" Or Mid(Str1, i + 1, 1) = "/" Or Mid(Str1, i + 1, 1) = "^" Or Mid(Str1, i + 1, 1) = "-" Or Mid(Str1, i + 1, 1) = "") Then
            Else
                MsgBox "计算式错误。", vbOKOnly + vbExclamation, "错误!"
                 Exit Function
            End If
            s2 = s2 + 1
            If s1 < s2 Then
                 MsgBox "括号不匹配或计算式错误。", vbOKOnly + vbExclamation, "错误!"
                 Exit Function
            End If
  
        Case "+", "*", "/", "^", "-"
            If Mid(Str1, i + 1, 1) = "*" Or Mid(Str1, i + 1, 1) = "/" Or Mid(Str1, i + 1, 1) = "^" Or Mid(Str1, i + 1, 1) = "-" Or Mid(Str1, i + 1, 1) = "+" Or Mid(Str1, i + 1, 1) = "." Then
                MsgBox "计算式错误。", vbOKOnly + vbExclamation, "错误!"
                Exit Function
            End If
        End Select
        
        C1 = ReadChar(StrTemp)
        i = i + 1
   Loop
   If s1 <> s2 Then
      MsgBox "括号不匹配,请仔细检查!", vbOKOnly + vbExclamation, "错误!"
      Exit Function
   End If
   '检查完毕*************************************************
   Str1 = UCase(Str1)
   Str1 = Replace(Str1, "PI", pi)
   CheckString = Str1
End Function

' 读入数字
' 参数： Str1 处理的字符串
' 返回：  取到的数字， "" 为错误！
'        Str1 ：处理后字符串
Private Function ReadNumber(Str1 As String) As String
  Dim C1 As String, i As Integer
  Dim rets As String
  rets = ""
  C1 = ReadChar(Str1)
  i = i + 1
  Do While C1 <> ""
    If i = 1 And C1 = "-" Then
        If Mid(Str1, 1, 1) = "(" Then    '处理括号前面的负号
            rets = DealBlank(Str1)
            rets = C1 & rets
            Exit Do
        ElseIf IsNumeric(Mid(Str1, 1, 1)) Then   '处理负数
            rets = C1
        End If
    Else
        If (C1 >= "0" And C1 <= "9") Or C1 = "." Then
          rets = rets & C1
        Else
          RetChar Str1, C1
          Exit Do
        End If
    End If
    
    C1 = ReadChar(Str1)
    i = i + 1
  Loop
  If Not IsNumeric(rets) Then
  MsgBox rets
    MsgBox "数字输入错误,请仔细检查!", vbOKOnly + vbExclamation, "错误!"
    rets = ""
  End If
  ReadNumber = rets
End Function

' 读入操作符
' 参数： Str1 处理的字符串
' 返回：  取到的操作符， "" 为错误！
'        Str1 ：处理后字符串
Private Function ReadOp(Str1 As String) As String
    Dim C1 As String
    Dim rets As String
    C1 = ReadChar(Str1)
    If C1 = "*" Or C1 = "-" Or C1 = "+" Or C1 = "/" Or C1 = "^" Then
        ReadOp = C1
    Else
        RetChar Str1, C1
        ReadOp = ""
    End If
End Function

' 读入函数      注意：函数必须带括号
' 参数： Str1 处理的字符串
' 返回：  取到的函数值， "" 为错误！
'        Str1 ：处理后字符串

Private Function ReadFunction(Str1 As String) As String
  On Error GoTo err
  Dim C1 As String, C2 As String

  C1 = ReadChar(Str1)
  Do While C1 <> "" And C1 <> "("
    C2 = C2 & C1
    C1 = ReadChar(Str1)
  Loop
  RetChar Str1, C1
  Select Case Trim(UCase(C2))
    Case "SIN"    ' 正弦
      C1 = DealBlank(Str1)
      ReadFunction = CStr(Sin(Val(C1)))
    Case "COS"    ' 余弦
      C1 = DealBlank(Str1)
      ReadFunction = CStr(Cos(Val(C1)))
    Case "ASIN"    ' 反正弦
      C1 = DealBlank(Str1)
      ReadFunction = Asin(C1)
    Case "ACOS"    ' 反余弦
      C1 = DealBlank(Str1)
      ReadFunction = Acos(Val(C1))
    Case "TAN"    ' 正切
      C1 = DealBlank(Str1)
      ReadFunction = CStr(Tan(Val(C1)))
    Case "ATN"    ' 反正切
      C1 = DealBlank(Str1)
      ReadFunction = CStr(Atn(Val(C1)))
    Case "LN"    ' 自然对数
      C1 = DealBlank(Str1)
      If Val(C1) <= 0 Then MsgBox "算式错误,对数函数的真数必须为正数,请仔细检查!", vbOKOnly + vbExclamation, "错误!"
      ReadFunction = Log(Val(C1))
    Case "EXP"    ' e的幂
      C1 = DealBlank(Str1)
      ReadFunction = CStr(Exp(Val(C1)))
    Case "LOG"    ' 常用对数
      C1 = DealBlank(Str1)
      If Val(C1) <= 0 Then MsgBox "算式错误,对数函数的真数必须为正数,请仔细检查!", vbOKOnly + vbExclamation, "错误!"
      ReadFunction = Log(Val(C1)) / Log(10)
    Case "JCH"    ' 阶乘
      C1 = DealBlank(Str1)
      ReadFunction = JCh(C1)
    Case "SQR"    ' 平方根
      C1 = DealBlank(Str1)
      If Val(C1) < 0 Then MsgBox "算式错误,不支持负数开平方!", vbOKOnly + vbExclamation, "错误!"
      ReadFunction = CStr(Sqr(Val(C1)))
    Case "INT"    ' 取整
      C1 = DealBlank(Str1)
      ReadFunction = CStr(Int(Val(C1)))
  End Select
err:
End Function


' 取下一个数,数值或函数值或括号里的值
' 参数： Str1 　　处理的字符串
' 返回：  取到的函数值， "" 为错误！
'        Str1 ：处理后字符串
Private Function GetValue(Str1 As String) As String
  Dim C1 As String

  C1 = ReadChar(Str1)
  RetChar Str1, C1
  Select Case C1
    Case "("
      GetValue = DealBlank(Str1)
    Case "0" To "9", "-"
      GetValue = ReadNumber(Str1)
    Case Else
      GetValue = ReadFunction(Str1)
  End Select
End Function

Private Function GetExp(Str1 As String) As String
    Dim Val1 As String, Op1 As String

    Val1 = GetValue(Str1)
    Op1 = ReadOp(Str1)
    GetExp = SinglCal(Str1, Val1, Op1)
End Function


Private Function CompStr(Val1, Op, Val2) As String
    On Error GoTo err
    Dim NewVal
    Select Case Op
      Case "-"
        NewVal = Val(Val1) - Val(Val2)
      Case "+"
        NewVal = Val(Val1) + Val(Val2)
      Case "*"
        NewVal = Val(Val1) * Val(Val2)
      Case "/"
        If Val(Val2) <> 0 Then
          NewVal = Val(Val1) / Val(Val2)
        Else
           MsgBox "算式错误,导致了0作除数!", vbOKOnly + vbExclamation, "错误!"
        End If
      Case "^"
        If Val(Val1) = 0 And Val(Val2) < 0 Then
          MsgBox "算式错误,导致了0作除数!", vbOKOnly + vbExclamation, "错误!"
        Else
          NewVal = Val(Val1) ^ Val(Val2)
        End If
      Case Else
        NewVal = Val1
    End Select
    CompStr = CStr(NewVal)
err:
End Function

'计算表达式函数入口
Public Function Start(Str1 As String) As String
    Dim strCal As String
    strCal = CheckString(Str1)
    Start = GetExp(strCal)
End Function

'处理括号
' 参数： Str1 　　处理的字符串
' 返回：  括号中表达式计算后的数值， "" 为错误！
'        Str1 ：处理后字符串
Private Function DealBlank(Str1 As String) As String
    Dim C1 As String, C2 As String, StrTem As String
    Dim N1 As Integer, N2 As Integer, N3 As Integer
    StrTem = Str1
    C1 = ReadChar(StrTem)
    N1 = N1 + 1
    N3 = N3 + 1
    Do While C1 <> "" And N1 <> N2
        C1 = ReadChar(StrTem)
        If C1 = "(" Then N1 = N1 + 1
        If C1 = ")" Then N2 = N2 + 1
        N3 = N3 + 1
    Loop
    If N1 <> N2 Then
        MsgBox "括号不匹配。", vbOKOnly + vbExclamation, "错误!"
        Exit Function
    End If
    
    C1 = Left(Str1, N3)
    C1 = Mid(C1, 2, Len(C1) - 2)
    C2 = Mid(Str1, N3 + 1)
    Str1 = C2
    DealBlank = GetExp(C1)
End Function
'判断运算级别,opt2级高于opt1,则值为True
Private Function ComDegree(opt1, opt2) As Boolean
    Select Case opt1
    Case "+", "-"
        If opt2 = "+" Or opt2 = "-" Then
            ComDegree = False
        Else
            ComDegree = True
        End If
    Case "*", "/"
        If opt2 = "^" Then
           ComDegree = True
        Else
           ComDegree = False
        End If
    Case "^"
        ComDegree = False
    End Select
End Function

'只有一个运算符Op1
Private Function SinglCal(Str1 As String, Val1 As String, Op1 As String) As String
Dim Val2 As String, Op2 As String
    If Op1 <> "" Then
        Val2 = GetValue(Str1)
        Op2 = ReadOp(Str1)
        SinglCal = TwoCal(Str1, Val1, Val2, Op1, Op2)
    Else
        SinglCal = Val1
    End If
End Function

'有二个运算符Op1、Op2
Private Function TwoCal(Str1 As String, Val1 As String, Val2 As String, _
        Op1 As String, Op2 As String) As String
    Dim Val3 As String, Op3 As String
    If Op2 <> "" Then
        If Not (ComDegree(Op1, Op2)) Then
            Val1 = CompStr(Val1, Op1, Val2)
            Op1 = Op2
            TwoCal = SinglCal(Str1, Val1, Op1)
        Else
            Val3 = GetValue(Str1)
            Op3 = ReadOp(Str1)
            TwoCal = ThreeCal(Str1, Val1, Val2, Val3, Op1, Op2, Op3)
        End If
    Else
        Val1 = CompStr(Val1, Op1, Val2)
        Op1 = ""
        TwoCal = SinglCal(Str1, Val1, Op1)
    End If
End Function

'有三个运算符
Private Function ThreeCal(Str1 As String, Val1 As String, Val2 As String, _
        Val3 As String, Op1 As String, Op2 As String, Op3 As String) As String
    Dim Val4 As String, Op4 As String
    If Op3 <> "" Then
        If ComDegree(Op2, Op3) Then
            Val4 = GetValue(Str1)
            Op4 = ReadOp(Str1)
            ThreeCal = FourCal(Str1, Val1, Val2, Val3, Val4, Op1, Op2, Op3, Op4)
        Else
            Val2 = CompStr(Val2, Op2, Val3)
            Op2 = Op3
            ThreeCal = TwoCal(Str1, Val1, Val2, Op1, Op2)
        End If
    Else         ' Op3 = ""
        Val2 = CompStr(Val2, Op2, Val3)
        Val1 = CompStr(Val1, Op1, Val2)
        Op1 = ""
        ThreeCal = SinglCal(Str1, Val1, Op1)
    End If
End Function

'有四个运算符
Private Function FourCal(Str1 As String, Val1 As String, Val2 As String, _
        Val3 As String, Val4 As String, Op1 As String, Op2 As String, _
        Op3 As String, Op4 As String) As String
    If Op4 <> "" Then
        Val3 = CompStr(Val3, Op3, Val4)
        Op3 = Op4
        FourCal = ThreeCal(Str1, Val1, Val2, Val3, Op1, Op2, Op3)
    Else
        Val3 = CompStr(Val3, Op3, Val4)
        Val2 = CompStr(Val2, Op2, Val3)
        Val1 = CompStr(Val1, Op1, Val2)
        Op1 = ""
        FourCal = SinglCal(Str1, Val1, Op1)
    End If
End Function