计算 字符串数学表达式

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