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

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

 von Arne Elster

'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

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

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.

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

Call Zeichnen(clsParser.String, 10)