Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0703: Einfache arithmetische Ausdrücke auswerten

 von 

Beschreibung 

Dieser einfache Parser löst arithmetische Ausdrücke mit Infixnotation. Unterstützt werden die Operatoren +, -, *, /, ^ und Klammern, außerdem kann man eigene mit einem Wert belegte Variablen definieren.
Gegenüber dem Script Control bietet der Code kompiliert zu Native Code auch einen deutlichen Geschwindigkeitsvorteil.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

keine

Download:

Download des Beispielprojektes [4,26 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "Text1"

Option Explicit

Private Sub Command1_Click()
    Dim clsExpr As Expression
    Set clsExpr = New Expression

    clsExpr.AddVariable "e", Exp(1)
    clsExpr.AddVariable "pi", Atn(1) * 4

    clsExpr.ExpressionString = Text1.Text

    If clsExpr.SolveExpression Then
        MsgBox Text1.Text & " = " & clsExpr.Result
    Else
        MsgBox "Fehler beim Parsen!"
    End If
End Sub

Private Sub Bench()
    Const fnc As String = "((2.71828*3.14159)^0.5-10+0.0777176346777) / -10"
    Const itr As Long = 10000
    
    Dim i As Long
    Dim d As Double
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
        
    Dim obj As Object
    Set obj = CreateObject("ScriptControl")
    
    obj.Language = "VBScript"
    obj.AddCode "sub main()" & vbCrLf & _
                    "x = " & fnc & vbCrLf & _
                "end sub"
    
    d = Timer
    For i = 1 To itr
        obj.run "main"
    Next
    MsgBox "ScriptCtrl: " & (Timer - d) * 1000 & " ms", , "Benchmark"
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
        
    Dim clsExpr As Expression
    Set clsExpr = New Expression
    
    clsExpr.ExpressionString = fnc
    
    d = Timer
    For i = 1 To itr
        clsExpr.SolveExpression
    Next
    MsgBox "Expression: " & (Timer - d) * 1000 & " ms", , "Benchmark"
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Set obj = Nothing
    Set clsExpr = Nothing
End Sub

Private Sub Form_Load()
    Bench
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'----- Anfang Klasse "Expression" alias Expression.cls  -----

Option Explicit

Private Type Token
    Type        As TokenType
    content     As Double
    varidx      As Long
End Type

Private Type Variable
    Name        As String
    content     As Double
End Type

Private Enum TokenType
    token_unk = &H0
    token_val = &H1
    token_end = &H2
    token_var = &H3
    token_add = &H2B
    token_sub = &H2D
    token_mul = &H2A
    token_div = &H2F
    token_pow = &H5E
    token_parl = &H28
    token_parr = &H29
End Enum

Private m_strExpr   As String
Private m_lngPos    As Long
Private m_tkn()     As Token
Private m_lngCurTkn As Long
Private m_vars()    As Variable
Private m_lngVars   As Long

Private m_dblResult As Double

Public Function AddVariable(ByVal strVar As String, ByVal value As Double) As Boolean
    Dim i As Long
    
    For i = 0 To m_lngVars - 1
        If StrComp(strVar, m_vars(i).Name, vbTextCompare) = 0 Then
            Exit Function
        End If
    Next
    
    ReDim Preserve m_vars(m_lngVars) As Variable
    m_vars(m_lngVars).Name = strVar
    m_vars(m_lngVars).content = value
    m_lngVars = m_lngVars + 1
    
    AddVariable = True
End Function

Public Function RemVariable(ByVal strVar As String) As Boolean
    Dim i   As Long
    Dim j   As Long
    
    For i = 0 To m_lngVars - 1
        If StrComp(strVar, m_vars(i).Name, vbTextCompare) = 0 Then
            For j = i + 1 To m_lngVars - 1
                m_vars(j - 1) = m_vars(j)
            Next
            
            m_lngVars = m_lngVars - 1
            
            If m_lngVars = 0 Then
                Erase m_vars
            Else
                ReDim Preserve m_vars(m_lngVars - 1) As Variable
            End If
            
            RemVariable = True
            Exit For
        End If
    Next
End Function

Public Property Get VarCount() As Long
    VarCount = m_lngVars
End Property

Public Property Get VariableName(ByVal idx As Long) As String
    VariableName = m_vars(idx).Name
End Property

Public Property Get VariableValue(ByVal idx As Long) As Double
    VariableValue = m_vars(idx).content
End Property

Public Property Let VariableValue(ByVal idx As Long, ByVal dblVal As Double)
    m_vars(idx).content = dblVal
End Property

Public Property Get Result() As Double
    Result = m_dblResult
End Property

Public Property Get ExpressionString() As String
    ExpressionString = m_strExpr
End Property

Public Property Let ExpressionString(ByVal strExpr As String)
    Dim i As Long
    
    m_strExpr = strExpr
    m_lngPos = 1
    
    Do
        ReDim Preserve m_tkn(i) As Token
        m_tkn(i) = GetToken()
        i = i + 1
    Loop Until m_tkn(i - 1).Type = token_end
End Property

Public Function SolveExpression() As Boolean
    If Len(m_strExpr) > 0 Then
        m_lngCurTkn = 0
        m_dblResult = 0
        If Expression(m_dblResult) Then SolveExpression = Match(token_end)
    End If
End Function

Private Function Expression(dblRet As Double) As Boolean
    Dim dblRHS  As Double
    
    If Not Term(dblRet) Then Exit Function
    
    Do
        If Match(token_add) Then
            If Not Term(dblRHS) Then Exit Function
            dblRet = dblRet + dblRHS
        ElseIf Match(token_sub) Then
            If Not Term(dblRHS) Then Exit Function
            dblRet = dblRet - dblRHS
        Else
            Exit Do
        End If
    Loop
    
    Expression = True
End Function

Private Function Term(dblRet As Double) As Boolean
    Dim dblRHS  As Double
    
    If Not Factor(dblRet) Then Exit Function
    
    Do
        If Match(token_mul) Then
            If Not Factor(dblRHS) Then Exit Function
            dblRet = dblRet * dblRHS
        ElseIf Match(token_div) Then
            If Not Factor(dblRHS) Then Exit Function
            dblRet = dblRet / dblRHS
        Else
            Exit Do
        End If
    Loop
    
    Term = True
End Function

Private Function Factor(dblRet As Double) As Boolean
    Dim dblRHS  As Double
    
    With m_tkn(m_lngCurTkn)
        Select Case .Type
        
            Case token_sub
                m_lngCurTkn = m_lngCurTkn + 1
                If Not Factor(dblRet) Then Exit Function
                dblRet = -dblRet
            
            Case token_add
                m_lngCurTkn = m_lngCurTkn + 1
                If Not Factor(dblRet) Then Exit Function
                
            Case token_val
                dblRet = .content
                m_lngCurTkn = m_lngCurTkn + 1
                
            Case token_var
                dblRet = m_vars(.varidx).content
                m_lngCurTkn = m_lngCurTkn + 1
                
            Case token_parl
                m_lngCurTkn = m_lngCurTkn + 1
                If Not Expression(dblRet) Then Exit Function
                If Not Match(token_parr) Then Exit Function
                
            Case Else
                Exit Function
                
        End Select
    End With
    
    Do While Match(token_pow)
        If Not Factor(dblRHS) Then Exit Function
        dblRet = dblRet ^ dblRHS
    Loop

    Factor = True
End Function

Private Function Match(ByVal tk As TokenType) As Boolean
    If tk = m_tkn(m_lngCurTkn).Type Then
        m_lngCurTkn = m_lngCurTkn + 1
        Match = True
    End If
End Function

Private Function GetToken() As Token
    Dim blnGotToken As Boolean
    Dim strChr      As String
    
    If m_lngPos > Len(m_strExpr) Then
        GetToken.Type = token_end
        Exit Function
    End If
    
    Do While Not blnGotToken
        strChr = Mid$(m_strExpr, m_lngPos, 1)
        Select Case strChr
            Case " "
                '

            Case "+", "-", "*", "/", "^", "(", ")"
                GetToken.Type = Asc(strChr)
                blnGotToken = True
                
            Case "a" To "z", "A" To "Z":
                Dim strStr      As String
                Dim i           As Long
                
                Do While m_lngPos <= Len(m_strExpr)
                    If strChr Like "[a-zA-Z0-9]" Then
                        strStr = strStr & strChr
                        m_lngPos = m_lngPos + 1
                        strChr = Mid$(m_strExpr, m_lngPos, 1)
                    Else
                        m_lngPos = m_lngPos - 1
                        Exit Do
                    End If
                Loop
                
                For i = 0 To m_lngVars - 1
                    If StrComp(m_vars(i).Name, strStr, vbTextCompare) = 0 Then
                        GetToken.Type = token_var
                        GetToken.varidx = i
                        Exit For
                    End If
                Next
                If i = m_lngVars Then GetToken.Type = token_unk
                
                blnGotToken = True

            Case "0" To "9"
                Dim strValue    As String
                Dim blnGotDot   As Boolean
                
                Do While m_lngPos <= Len(m_strExpr)
                    Select Case True
                    
                        Case IsNumeric(strChr)
                            strValue = strValue & strChr
                            
                        Case strChr = "."
                            If Not blnGotDot Then
                                strValue = strValue & "."
                                blnGotDot = True
                            Else
                                Exit Do
                            End If
                            
                        Case Else
                            Exit Do
                            
                    End Select
                    
                    m_lngPos = m_lngPos + 1
                    strChr = Mid$(m_strExpr, m_lngPos, 1)
                Loop
                
                GetToken.Type = token_val
                GetToken.content = Val(strValue)
                
                m_lngPos = m_lngPos - 1
                blnGotToken = True
                
            Case Else
                GetToken.Type = token_unk
                blnGotToken = True
                
        End Select
        
        m_lngPos = m_lngPos + 1
    Loop
End Function
'------ Ende Klasse "Expression" alias Expression.cls  ------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 3 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Jonathan F. am 17.07.2011 um 16:16

Interessantes Programm.

Ich bin erst 14 Jahre alt und habe schon etliches programmiert.
Nun wollte ich mich an einem Parser für eine Scriptsprache zum Steuern eins Lego NXT-Moduls probieren. Der obige Code sollte als Vorlage dienen.
allerdings muss ich sagen, dass das ansteueren weit weniger Probleme bereitet als das parsen und interpretieren.
Deshalb suchte ich nach einer Lösung und stoß auf diesen Tipp hier:http://www.activevb.de/tutorials/tut_parser/tut_parser_1.html

Deshlab,Jan, probiere es mal damit, obwohl ich glaube, dass du nach 3 Jahren selber eine Lösung gefunden hast. :)

Gruss

Per aspera ad astra!

Kommentar von Jan am 13.08.2008 um 16:59

Ich habe eine kurze Frage.

Also an sich funktioniert der Parser einwandfrei, doch möchte ich ein Programm schreiben was eine beliebige Funktion nicht nur ausrechnen sondern auch zeichnen kann.

Das Zeichnen ist kein Problem, das habe ich schon alles geschrieben nur konnte man die Funktion bis jetzt nur durch eine Maske eingeben.

Danke dem Formelparser geht das natürlich auch durch ein Textfeld, aber nun habe ich ein Problem mit den Variablen, wenn ich zum Beispiel 1x^2 zeichnen möchte.

Public Function Zeichnen(Gleichung, Wert As String)
For X = -Wert To Wert Step 0.01
Gleichung = Val(txtFaktor) * X ^ Val(txtExponent)
Y = Gleichung
frmMain.Picture1.PSet (X, Y), vbRed
Next X
End Function


Damit zeichne ich die Funktion, zwar nicht die optimle, aber im anbetracht meines Zeitfensters die beste Lösung.

So nun habe ich 2 Fragen.
Ich rufe meine Funktion für das Zeichnen wie folgt auf:

Call Zeichnen(clsParser.String, 10)


1. Mit welchem String muss ich die Klasse aufrufen?
2. Werden Variablen wie X oder Y vom Parser erkannt?

mfg

Kommentar von Jonathan am 07.03.2008 um 15:03

Ich finde dieses Programm einfach nur Irre !!!
Ich bin erst 10 Jahre alt, aber programmiere schon und
habe so etwas auch schon einmal probiert. Hat nicht
geklappt.

Also:

Nur lob von meiner Seite !!!