计算 字符串数学表达式

‘参考自 http://blog.youkuaiyun.com/laviewpbt/article/details/1806217 ，并修改了一小点内容(带参数调用时，第二次调用出错问题)

Option Explicit

'定义的各算子的优先级
Private Const PREC_NONE = 11        '
Private Const PREC_UNARY = 10       '实际中没有用到
Private Const PREC_POWER = 9        '^
Private Const PREC_TIMES = 8        '*
Private Const PREC_DIV = 7          '/
Private Const PREC_INT_DIV = 6      '/
Private Const PREC_MOD = 5          'mod
Private Const PREC_PLUS = 4         '+





'自定义表达式计算：使用方法 Eval("3+4*exp(4)-sin(4/5)+abs(12/5)")  或带参数的  Eval("X1 + x0 * 2 + x3", 2, 4, 3, 6)
Public Function Eval(ByVal Expression As String, ParamArray Data() As Variant) As Double
    Dim Is_Unary        As Boolean
    Dim Next_Unary      As Boolean
    Dim Brackets        As Integer
    Dim Pos             As Integer
    Dim Expression_Len  As Integer
    Dim Char            As String
    Dim LeftExpression  As String
    Dim RightExpression As String
    Dim Value           As String
    Dim status          As Long
    Dim Best_Pos     As Integer
    Dim Best_Prec     As Integer
    Dim Temp1  As Double
    Dim Temp2       As Double
    Dim V As Variant
    Dim i As Long
    Static DeepLevel As Long
    

    If DeepLevel = 0 Then                                   '因为是递归，所以要防止重复做无用功
        Expression = LCase(Trim(Expression))        '删除首尾空格并把字符转换成小写
        For Each V In Data
            Expression = Replace(Expression, "x" & i, V)
            i = i + 1
        Next
    End If
    
    
    DeepLevel = DeepLevel + 1
    
    
    Expression_Len = Len(Expression)                '计算字符串的长度，一定要放在上面代码的下部
    If Expression_Len = 0 Then GoTo myend
    Is_Unary = True                                 '如果有+或-,则是单元运算符
    Best_Prec = PREC_NONE                           '到目前为止我们什么也没得到
    For Pos = 1 To Expression_Len
        Char = Mid(Expression, Pos, 1)              '检查下一个字符
        Next_Unary = False
        If Char = " " Then                          '跳过空格
            Next_Unary = Is_Unary
        ElseIf Char = "(" Then
            Brackets = Brackets + 1                 '增加括号的个数
            Next_Unary = True
        ElseIf Char = ")" Then
            Brackets = Brackets - 1                 '减少括号的个数
            Next_Unary = False
            If Brackets < 0 Then                    '左右括号的个数不配套
                Err.Raise vbObjectError + 1001, "错误", "表达式中左右括号的个数不配套"
            End If
        ElseIf Brackets = 0 Then
            If Char = "^" Or Char = "*" Or Char = "/" Or Char = "/" Or Char = "%" Or Char = "+" Or Char = "-" Then
                Next_Unary = True
                Select Case Char
                Case "^"
                    If Best_Prec >= PREC_POWER Then
                        Best_Prec = PREC_POWER
                        Best_Pos = Pos
                    End If
                Case "*", "/"
                    If Best_Prec >= PREC_TIMES Then
                        Best_Prec = PREC_TIMES
                        Best_Pos = Pos
                    End If
                  
                Case "/"
                    If Best_Prec >= PREC_INT_DIV Then
                        Best_Prec = PREC_INT_DIV
                        Best_Pos = Pos
                    End If
                
                Case "%"
                    If Best_Prec >= PREC_MOD Then
                        Best_Prec = PREC_MOD
                        Best_Pos = Pos
                    End If
                Case "+", "-"
                    If (Not Is_Unary) And Best_Prec >= PREC_PLUS Then
                        Best_Prec = PREC_PLUS
                        Best_Pos = Pos
                    End If
                End Select
            End If
        End If
        Is_Unary = Next_Unary
    Next
    If Brackets <> 0 Then
        Err.Raise vbObjectError + 1002, "错误", "表达式中丢失一个 )"
    End If
    If Best_Prec < PREC_NONE Then
        LeftExpression = Left(Expression, Best_Pos - 1)
        RightExpression = Right(Expression, Expression_Len - Best_Pos)
        Select Case Mid(Expression, Best_Pos, 1)
        Case "^"
            Eval = Eval(LeftExpression) ^ Eval(RightExpression)
        Case "*"
            Eval = Eval(LeftExpression) * Eval(RightExpression)
        Case "/"
            Temp1 = Eval(RightExpression)
            Temp2 = Eval(LeftExpression)
            If Temp1 = 0 Then
                Eval = 0
            Else
                Eval = Temp2 / Temp1
            End If
        Case "/"
            Eval = Eval(LeftExpression) / Eval(RightExpression)
        Case "%"
            Eval = Eval(LeftExpression) Mod Eval(RightExpression)
        Case "+"
            Eval = Eval(LeftExpression) + Eval(RightExpression)
        Case "-"
            Eval = Eval(LeftExpression) - Eval(RightExpression)
        End Select
        GoTo myend
    End If
    If Left(Expression, 1) = "(" And Right(Expression, 1) = ")" Then
        Eval = Eval(Mid(Expression, 2, Expression_Len - 2))
        GoTo myend
    End If
    If Left(Expression, 1) = "-" Then
        Eval = -Eval(Right(Expression, Expression_Len - 1))
        GoTo myend
    End If
    If Left(Expression, 1) = "+" Then
        Eval = Eval(Right(Expression, Expression_Len - 1))
        GoTo myend
    End If
    If Expression_Len > 5 And Right(Expression, 1) = ")" Then
        LeftExpression = Left(Expression, 4)
        RightExpression = Mid(Expression, 5, Expression_Len - 5)
        Select Case LeftExpression
        Case "sin("
            Eval = Sin(Eval(RightExpression))
        Case "cos("
            Eval = Cos(Eval(RightExpression))
        Case "tan("
            Eval = Tan(Eval(RightExpression))
        Case "sqr("
            Eval = Sqr(Eval(RightExpression))
        Case "abs("
            Eval = Abs(Eval(RightExpression))
        Case "exp("
            Eval = Exp(Eval(RightExpression))
        Case "log("
            Eval = Log(Eval(RightExpression))
        Case "sgn("
            Eval = Sgn(Eval(RightExpression))
        Case "atn("
            Eval = Atn(Eval(RightExpression))
        Case "rnd("
            Eval = Rnd(Eval(RightExpression))
        End Select

        GoTo myend
    End If
    On Error GoTo Errhandle:

    Eval = CDbl(Expression)

    GoTo myend
    
Errhandle:
    Err.Raise vbObjectError + 1003, "错误", "未知错误发生!"
    
myend:
    DeepLevel = DeepLevel - 1
  End Function




Public Function MSScriptEval(ByVal Expression As String) As Double
Dim scr As Object
Set scr = CreateObject("MSScriptControl.ScriptControl")
scr.Language = "vbscript"
MSScriptEval = scr.Eval(Expression)
Set scr = Nothing
End Function