vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#

https://www.vbarchiv.net
Rubrik: Variablen/Strings · Algorithmen/Mathematik   |   VB-Versionen: VB630.06.08
Arithmetische Ausdrücke auswerten

Ein simpler Weg, einfache Terme wie "(1+2)*3" zu lösen

Autor:   Arne ElsterBewertung:  Views:  11.259 
actorics.de/rm_codeSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

Dieser Tipp zeigt einen Weg, einfache arithmetische Ausdrücke zu lösen. Dabei geht der Parser von links nach rechts vor und beachtet auch Operatorrangfolgen. Klammerung wird ebenfalls unterstützt.

Ein Bonus dieser Vorgehensweise gegenüber der, das Script Control die Arbeit machen zu lassen, ist natürlich der, dass man eine Komponente weniger mitliefern muss.

Fügen Sie folgenden Code in ein Modul namens MathParser ein:

Option Explicit
 
Private Const TokenUnknown  As Long = 0
Private Const TokenOpAdd    As Long = 43
Private Const TokenOpSub    As Long = 45
Private Const TokenOpMul    As Long = 42
Private Const TokenOpDiv    As Long = 47
Private Const TokenParLeft  As Long = 40
Private Const TokenParRight As Long = 41
Private Const TokenValue    As Long = 256
Private Const TokenEnd      As Long = 257
 
Private Type Token
  TType   As Long
  Value   As Double
End Type
 
Private m_btInp() As Byte
Private m_lngInpLen As Long
Private m_lngInpPos As Long
Private m_lngParCnt As Long
Private m_udtToken  As Token
' Parser initialisieren und Ausdruck lösen
Public Function MathSolve(ByVal expr As String, _
  ByRef result As Double) As Boolean
 
  m_btInp = StrConv(expr, vbFromUnicode)
  m_lngInpLen = UBound(m_btInp) + 1
  m_lngInpPos = 0
  m_lngParCnt = 0
  result = 0
 
  GetNextToken
 
  If Expression(result) Then
    MathSolve = Match(TokenEnd) And (m_lngParCnt = 0)
  End If
End Function
' Expression() löst den gesamten Ausdruck durch Abarbeiten
' von Additionen und Subtraktionen, die die niedrigste Priorität haben
' (Punkt vor Strich) und wird aufgerufen um Ausdrücke in Klammern zu lösen
Private Function Expression(ByRef Value As Double) As Boolean
  Dim dblTerm As Double
 
  If Not Term(Value) Then Exit Function
  Do
    If Match(TokenOpAdd) Then
      If Not Term(dblTerm) Then Exit Function
      Value = Value + dblTerm
    ElseIf Match(TokenOpSub) Then
      If Not Term(dblTerm) Then Exit Function
      Value = Value - dblTerm
    Else
      If Match(TokenParRight) Then m_lngParCnt = m_lngParCnt - 1
      Exit Do
    End If
  Loop
  Expression = True
End Function
' Term() löst Multiplikationen und Divisionen
Private Function Term(ByRef Value As Double) As Boolean
  Dim dblFactor As Double
 
  If Not Factor(Value) Then Exit Function
  Do
    If Match(TokenOpMul) Then
      If Not Factor(dblFactor) Then Exit Function
      Value = Value * dblFactor
    ElseIf Match(TokenOpDiv) Then
      If Not Factor(dblFactor) Then Exit Function
      If dblFactor = 0 Then Exit Function
      Value = Value / dblFactor
    Else
      Exit Do
    End If
  Loop
  Term = True
End Function
' Faktor kann eine Zahl oder eine Klammer sein
' Im Fall der Klammer Expression() aufrufen um sie zu lösen
Private Function Factor(ByRef dblFactor As Double) As Boolean
  Dim blnNeg As Boolean
 
  blnNeg = Match(TokenOpSub)
  If Peek(TokenValue) Then
    dblFactor = m_udtToken.Value
    GetNextToken
    Factor = True
  ElseIf Peek(TokenParLeft) Then
    GetNextToken
    m_lngParCnt = m_lngParCnt + 1
    Factor = Expression(dblFactor)
  End If
  If blnNeg Then dblFactor = -dblFactor
End Function
' Typ des aktuellen Tokens prüfen ohne es weiter zu verändern
Private Function Peek(ByVal lngType As Long) As Boolean
  Peek = m_udtToken.TType = lngType
End Function
' Stimmt der Typ des aktuellen Tokens überein mit lngType,
' nächstes Token aus dem Stream holen
Private Function Match(ByVal lngType As Long) As Boolean
  If lngType = m_udtToken.TType Then
    GetNextToken
    Match = True
  End If
End Function
' Nächstes Token aus Stream holen (Zahl oder Operator)
Private Sub GetNextToken()
  Dim strNum As String
  Dim blnDot As Boolean
 
  m_udtToken.TType = TokenUnknown
 
  Do While m_lngInpPos < m_lngInpLen
    Select Case m_btInp(m_lngInpPos)
      Case Asc(" ")
        m_lngInpPos = m_lngInpPos + 1
 
       Case 48 To 57
         Do
           If m_btInp(m_lngInpPos) = 46 Then
             If blnDot Then
               Exit Do
             Else
               blnDot = True
             End If
           End If
           strNum = strNum & ChrW$(m_btInp(m_lngInpPos))
           m_lngInpPos = m_lngInpPos + 1
           If m_lngInpPos = m_lngInpLen Then Exit Do
         Loop While IsNumber(m_btInp(m_lngInpPos))
         m_udtToken.TType = TokenValue
         m_udtToken.Value = Val(strNum)
 
       Case Else
         m_udtToken.TType = m_btInp(m_lngInpPos)
         m_lngInpPos = m_lngInpPos + 1
 
    End Select
 
    If m_udtToken.TType <> TokenUnknown Then Exit Sub
  Loop
 
  m_udtToken.TType = TokenEnd
End Sub
Private Function IsNumber(ByVal char As Byte) As Boolean
  IsNumber = (char >= 48 And char <= 57) Or (char = 46)
End Function

Um nun einen Term zu lösen, kann man einfach folgendes Schema verwenden:

Dim dblResult As Double
If MathSolve(" ( 1 + 2.5 ) * 3 ", dblResult) Then
  MsgBox "Ergebnis: " & dblResult
Else
  MsgBox "Fehler im Ausdruck!"
End If



Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
 
Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.


Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.