VB 5/6-Tipp 0703: Einfache arithmetische Ausdrücke auswerten
von Arne Elster
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: | Verwendete API-Aufrufe: keine | Download: |
'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-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB5 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB6 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
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 !!!