RECURSIVE DESCENT PARSER FOR NUMERIC EXPRESSIONS

Option Explicit
Private Const NON_NUMERIC = 1
Private Const PARENTHESIS_EXPECTED = 2
Private Const NON_NUMERIC_DESCR = "Non numeric value"
Private Const PARENTESIS_DESCR = "Parenthesis expected"
Private Token As Variant   'Current token
'*********************************************************************
'*
'*   RECURSIVE DESCENT PARSER FOR NUMERIC EXPRESSIONS
'*
'* The function parses an string and returns the result.
'* If the string is empty the string "Empty" is returned.
'* If an error occurs the string "Error" is returned.
'*
'* The parser handles numerical expression with parentheses
'* unary operators + and -
'*
'* The following table gives the rules of precedence and associativity
'* for the operators:
'*
'* Operators on the same line have the same precedence and all operators
'* on a given line have higher precedence than those on the line below.
'*
'* -----------------------------------------------------------
'* Operators  Type of operation      Associativity
'*   ( )     Expression         Left to right
'*   + -     Unary            Right to left
'*   * /     Multiplication division   Left to right
'* -----------------------------------------------------------
'*
'* Sven-Erik Dahlrot [email protected]
'*
'*********************************************************************
Public Function EvaluateString(expr As String) As String
  Dim result As Variant
  Dim s1 As String
  Dim s2 As String   'White space characters
  Dim s3 As String   'Operators
    
  s2 = " " & vbTab   'White space characters
  s3 = "+-/*()"    'Operators
   
  On Error GoTo EvaluateString_Error
   
  Token = getToken(expr, s2, s3)  'Initialize
    
   EvalExp result         'Evaluate expression
    
   EvaluateString = result
Exit Function
EvaluateString_Error:
  EvaluateString = "Error"
End Function
'**** EVALUATE AN EXPRESSION
Private Function EvalExp(ByRef data As Variant)
  
  If Token <> vbNull And Token <> "" Then
    EvalExp2 data
  Else
    data = "Empty"
  End If
End Function
'* ADD OR SUBTRACT TERMS
Private Function EvalExp2(ByRef data As Variant)
  Dim op As String
  Dim tdata As Variant
  
  EvalExp3 data
  
  op = Token
  Do While op = "+" Or op = "-"
    Token = getToken(Null, "", "")
    EvalExp3 tdata
    
    Select Case op
    
      Case "+"
        data = Val(data) + Val(tdata)
      Case "-"
        data = Val(data) - Val(tdata)
    End Select
    
    op = Token
  Loop
End Function
'**** MULTIPLY OR DIVIDE FACTORS
Private Function EvalExp3(ByRef data As Variant)
  Dim op As String
  Dim tdata As Variant
  
  EvalExp4 data
  
  op = Token
  Do While op = "*" Or op = "/"
    Token = getToken(Null, "", "")
    EvalExp4 tdata
    Select Case op
      Case "*"
        data = Val(data) * Val(tdata)
      Case "/"
        data = Val(data) / Val(tdata)
    End Select
    
    op = Token
  Loop
End Function
'**** UNARY EXPRESSION
Private Function EvalExp4(ByRef data As Variant)
  Dim op As String
  
  If Token = "+" Or Token = "-" Then
    op = Token
    Token = getToken(Null, "", "")
  End If
  
  EvalExp5 data
  
  If op = "-" Then data = -Val(data)
 
 End Function
'**** PROCESS PARENTHESIZED EXPRESSION
Private Function EvalExp5(ByRef data As Variant)
  
  If Token = "(" Then
    Token = getToken(Null, "", "")
    EvalExp data           'Subexpression
    If Token <> ")" Then
      Err.Raise vbObjectError + PARENTHESIS_EXPECTED, "Expression parser", PARENTESIS_DESCR
    End If
    
    Token = getToken(Null, "", "")
  Else
    EvalAtom data
  End If
End Function
'* GET VALUE
Private Function EvalAtom(ByRef data As Variant)
  If IsNumeric(Token) Then
    data = Token
  Else
    Err.Raise vbObjectError + NON_NUMERIC, "Expression parser", NON_NUMERIC_DESCR
  End If
  Token = getToken(Null, "", "")
End Function
'****************************************************************
'*
'* Tokenizer function
'*
'*
'* When first time called s1 must contain the string to be tokenized
'* and s2, s3 the delimites and operators, otherwise s1 should be Null
'* and s2,s3 empty strings ""
'*
'* s2 contains delimiters
'* s3 contains operators that act as both delimiters and tokens
'*
'* If no delimiter can be found in s1 the whole local copy is returned
'* If there are no more tokens left, Null is returned
'* If one delimiter follows another, the empty string "" is returned
'*
'* s1 is declared as Variant, because VB doesn't like to assign Null to a string.
'*
'****************************************************************
Public Function getToken(s1 As Variant, s2 As String, s3 As String) As Variant
    Static stmp As Variant
    Static wspace As String
    Static operators As String
    Dim i As Integer
    Dim schr As String
    
    getToken = Null
    
    'Initialize first time calling
    If s1 <> "" Then
        stmp = s1
        wspace = s2
        operators = s3
    End If
    'Nothing left to tokenize!
    If VarType(stmp) = vbNull Then
        Exit Function
    End If
    'Loop until we find a delimiter or operator
    For i = 1 To Len(stmp)
      schr = Mid$(stmp, i, 1)
      If InStr(1, wspace, schr, vbTextCompare) = 0 Then    'White space
        If InStr(1, operators, schr, vbTextCompare) Then  'Operator
          getToken = Mid$(stmp, i, 1)            'Get it
          stmp = Mid(stmp, i + 1, Len(stmp))
          Exit Function
        Else                    'It is a numeric value
          getToken = ""
          schr = Mid$(stmp, i, 1)
          Do While (schr >= "0" And schr <= "9") Or schr = "."
            getToken = getToken & schr
            i = i + 1
            schr = Mid$(stmp, i, 1)
          Loop
          If IsNumeric(getToken) Then
            stmp = Mid$(stmp, i, Len(stmp))
            Exit Function
          End If
        End If
      End If
    Next i
    'No tokens was found, return whatever is left in stmp
    
    getToken = stmp
    stmp = Null
    
End Function

Upload
Upload