快速计算字符串表达式的值！

最新推荐文章于 2021-10-27 18:06:25 发布

ssihc0

最新推荐文章于 2021-10-27 18:06:25 发布

阅读量1.1k

点赞数

文章标签： webbrowser function string integer command vbscript

在很多情况下，我们需要计算一个字符串表达式的值，比如由用户指定函数，然后做出这个函数的曲线，再如，用最速下降法编写求函数最大最小值的程序等等，这些程序由于要具有一定的通用性，函数表达式的一般都是由用户后期指定的，并且在代码的处理过程中会经常计算在不同变量值情况下函数的值，因此，我们不可以把函数表达式固化在程序中，只能利用相关的脚本或函数进行计算。

在CSDN的VB论坛中，每当有类似于这两个问题的时候，大部分给出的答案就是：

(1)利用API函数EbExecuteLine .

Private Declare Function EbExecuteLine Lib "VBa6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long

Private Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function

Private Function Eval(ByVal Expression As String) As String
    ExecuteLine "dim Expression as double"
    ExecuteLine "Expression= " & Expression
    ExecuteLine "CliPBoard.SetText Expression"
    Eval = Clipboard.GetText
End Function

Private Sub Command1_Click()
Text1.Text = Eval("3+4*exp(4)-sin(4/5)+abs(12/5)")
End Sub

从上述代码的表述上看，代码比较晦涩，过程比较繁琐，还需要借助于剪贴板,因此整个过程的执行效率比较低下，并且一个致命的问题是，程序编译之后不可以使用，因此，我觉得这个函数的功能有限。

（2）借助于其他脚本的EVAL函数，比如scriptcontrol控件，典型的有如下几种.

a、

在工程中添加“Microsoft   Script   Control1.0”控件

Private   Sub   Command1_Click()
          MsgBox   Me.ScriptControl1.Eval("3+4*exp(4)-sin(4/5)+abs(12/5)")
End   Sub

b、

Private Sub Command1_Click()
    Dim test     As String
    test = "3+4*exp(4)-sin(4/5)+abs(12/5)"
    Set scr = CreateObject("MSScriptControl.ScriptControl")
    scr.Language = "vbscript"
    MsgBox test & "=" & scr.Eval(test)
End Sub

c、用WebBrowser控件

Private Sub Command1_Click()
WebBrowser1.Navigate "javascript:" & "3+4*exp(4)-sin(4/5)+abs(12/5)"
msgbox WebBrowser1.Document.body.innerHTML
End Sub

用这些代码，问题都可以得到解决，但是蜗牛的速度总是有人不满意的。在大量的函数值计算中，效率并不高，并且在程序的传播中还要附带一个只用了它一点功能的控件，心里面总是有些惆怅，那么如何才能只用最基本的VB语言实现高速的计算函数表达式值呢。

我没学过数据结构，也只自己看了一点点，让我自己去写个这种函数解释器，不是说写不出来，那总要花个半个月的时间吧，呵呵，不过大家不要失望，已经有很多高人把这些问题替我们解决了，仔细的搜索CSDN的论坛，还是能够找到一些这方面的东西，C方面的居多，VB的呵呵居然也有一个，我记得很久以前看过，不过那时没在意，现在重新搜了搜，还在，大家有兴趣就浏览一下吧。

http://topic.csdn.net/t/20040801/14/3231596.html

那么，这里，我根据实际的需求对上述网址的函数进行了改进，使得更能适合实际的需求，因为实际中我们一般是知道一个表达式，如x0+x1^2+sin(x3)这种形式，求x0,x1,x2在不同值时函数的值，而并不是类似于3+4*exp(4)-sin(4/5)+abs(12/5）这样的纯数学表达式，所以要对参数进行解释。

主要代码如下：

'定义的各算子的优先级
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         '+

Private 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
    Static i As Long
    If i = 0 Then                                   '因为是递归，所以要防止重复做无用功
        Expression = LCase(Trim(Expression))        '删除首尾空格并把字符转换成小写
        For Each V In Data
            Expression = Replace(Expression, "x" & i, V)
            i = i + 1
        Next
    End If
    Expression_Len = Len(Expression)                '计算字符串的长度，一定要放在上面代码的下部
    If Expression_Len = 0 Then Exit Function
    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
        Exit Function
    End If
    If Left(Expression, 1) = "(" And Right(Expression, 1) = ")" Then
        Eval = Eval(Mid(Expression, 2, Expression_Len - 2))
        Exit Function
    End If
    If Left(Expression, 1) = "-" Then
        Eval = -Eval(Right(Expression, Expression_Len - 1))
        Exit Function
    End If
    If Left(Expression, 1) = "+" Then
        Eval = Eval(Right(Expression, Expression_Len - 1))
        Exit Function
    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
        Exit Function
    End If
    On Error GoTo Errhandle:
    Eval = CDbl(Expression)
    Exit Function
Errhandle:
    Err.Raise vbObjectError + 1003, "错误", "未知错误发生!"
End Function

在上述代码中，对部分进行解释：

（1）首先我们规定变量名的形式为 xn,其中n为0,1,2,3....，并且一个表达式中如果有m个变量，则变量名一定要为x0,x1,x2,..xm，如果某一个变量的系数为0，也不可以省略，但可写为0*xk的形式。当然，适当改变代码，可以改变命名规则。

（2） If i = 0 Then '因为是递归，所以要防止重复做无用功

这一if ....end if 段代码即为实现上述过程的关键部分，因为这个函数解释器是个递归的过程，所以为了不重复用数字替换表达式中的变量字符（如果不这样写，也没事，但是除了第一次调用该函数时会有字符替换，以后的各次都不会出现），定义了一个static类型的变量。用LCase把所有的字符都转换为小写，这提高了输入表达式的灵活性（X大小写就没有区别了)，增强程序的鲁棒性，同时把改语句放在此if ....end if 语句内也是为了提高程序的效率，避免重复调用。

（3）把其他的几个常用的函数也添加到了函数中，当然这不算什么，只是多了些体力劳动。不过，对于rnd的调用形式应该为rnd(n),其中n为自然数。否则会出错。

（4）程序没有对自变量的个数进行检查，也就是说，如果表达式中含有x0,x1,x2三个自变量，但是在调用时的ParamArray 这赋予了两个值，比如形如Eval("x1+x0*2+x3,2,4)这样的调用将会出错，但是形如Eval("x1+x0*2+x3,2,4,3,6)则没有问题。

（5）对于纯数字的表达式，上函数也可以直接计算，如： s = Eval("3+4*exp(4)-sin(4/5)+abs(12/5)")

速度比较：

比较代码：

（1）EbExecuteLine ,主要代码：

Private Sub Command1_Click()
    Dim test   As String
    Dim t As Double
    Dim s As Double
    Dim i As Long
    test = "3+4*exp(4)-sin(4/5)+abs(12/5)"
    t = Timer
    For i = 0 To 10000
        s = Eval(test)
    Next
    MsgBox Timer - t
End Sub

（2） ScriptControl控件，主要代码如下：

Private Sub Command1_Click()
    Dim test   As String
    Dim t As Double
    Dim s As Double
    Dim i As Long
    test = "3+4*exp(4)-sin(4/5)+abs(12/5)"
    Set scr = CreateObject("MSScriptControl.ScriptControl")
    scr.Language = "vbscript"
    t = Timer
    For i = 0 To 10000
        s = scr.Eval(test)
    Next
    MsgBox Timer - t
    Set scr = Nothing
End Sub

（3）我们的函数解释器，主要代码如下：

Private Sub Command1_Click()
    Dim i As Long
    Dim t As Double
    Dim s As Double
    t = Timer
    For i = 0 To 10000
        s = Eval("3+4*exp(4)-sin(4/5)+abs(12/5)")
    Next
    MsgBox Timer - t
End Sub

计算速度比较：

（1） 7.25s （VB环境下）（2）2.45s （3）2.00s

说明：（2）和（3）是编译后的速度比较，但是这里有一点是不公平的，3中的replace函数如果去掉的话速度为1.7s。

欢迎大家在此基础上继续改进和增强功能。