Source Code:

• FormCalculator
• Module- MathParser

Dim string1 As String
Dim value1 As Single
Dim ctr As Integer
Dim Equation() As String
Dim EquationLength As Integer
Dim ErrorCodes() As String
Private Sub Command1_Click()
  Call CountFunc
End Sub
Private Sub CountFunc()
  ctr = ctr + 1
  TextOutput.Text = TextOutput.Text + vbCrLf + Str(ctr)
  If ctr < 10 Then
    Call CountFunc
  End If
End Sub

Private Sub Command2_Click()
  test = 5
  string1 = "(3 + 2)*5"
  Call MathParser.EvaluateString(string1, Value, ErrorCodes())
  NumberErrors = Val(ErrorCodes(0, 0))
  If NumberErrors = 0 Then
    TextOutput.Text = string1 + vbCrLf + Str(Value) + vbCrLf + vbCrLf + TextOutput.Text
  Else
    TempString = "Error"
    For ctr = 1 To NumberErrors
      TempString = TempString + vbCrLf + "  " + ErrorCodes(ctr, 0)
      TempString = TempString + ", " + ErrorCodes(ctr, 1)
      TempString = TempString + ", " + Chr$(34) + ErrorCodes(ctr, 2) + Chr$(34)
    Next ctr
    TextOutput.Text = TempString + vbCrLf + vbCrLf + TextOutput.Text
  End If
End Sub

Private Sub EvaluateString2(somevar)
  somevar = somevar + 1
End Sub

Private Sub Form_Load()
  TextInput.Text = "Enter Expression Here"
  TextInput.SelStart = 0
  TextInput.SelLength = Len(TextInput.Text)
'    TextInput.SetFocus
End Sub

Private Sub TextInput_KeyUp(KeyCode As Integer, Shift As Integer)
  Dim EqString As String
  If KeyCode = vbKeyReturn Then
    TestString = TextInput.Text
    EqString = ""
        
    'Remove returns
    For ctr = 1 To Len(TextInput.Text)
      TestChar = Mid(TextInput.Text, ctr, 1)
      If Asc(TestChar) = 13 Or Asc(TestChar) = 10 Then
        EqString = EqString + ""
      Else
        EqString = EqString + TestChar
      End If
    Next ctr
    TextInput.Text = EqString

    TextInput.SelStart = 0
    TextInput.SelLength = Len(TextInput.Text)
    
    If Len(EqString) > 0 Then
      Call MathParser.EvaluateString(EqString, Value, ErrorCodes())
      NumberErrors = Val(ErrorCodes(0, 0))
      If NumberErrors = 0 Then
        TextOutput.Text = EqString + vbCrLf + Str(Value) + vbCrLf + vbCrLf + TextOutput.Text
      Else
        TempString = "Error"
        For ctr = 1 To NumberErrors
          TempString = TempString + vbCrLf + "  " + ErrorCodes(ctr, 0)
          TempString = TempString + ", " + ErrorCodes(ctr, 1)
          TempString = TempString + ", " + Chr$(34) + ErrorCodes(ctr, 2) + Chr$(34)
        Next ctr
        TextOutput.Text = TempString + vbCrLf + vbCrLf + TextOutput.Text
      End If
    End If
  End If
End Sub

Option Explicit
Dim Eq() As String
Dim Parsed As Boolean
Dim EqLength As Integer
Dim ErrorCodes As String
Dim Errors() As String  '(0,0)- Number Errors, 0 - Error Code, 1 - Message, 2 - StartLoc, 3 - StopLoc

Public Sub EvaluateString(EqString As String, Value, ErrorCodes() As String)
  Dim ctr As Integer
  Dim ctr2 As Integer
  Dim TempString As String
  Dim TestChar As String
  
  'Do some initial processing to remove all spaces
  For ctr = 1 To Len(EqString)
    TestChar = Mid(EqString, ctr, 1)
    If TestChar <> " " Then
      TempString = TempString + TestChar
    End If
  Next ctr
  EqString = TempString

  'Initialize Variables
  ReDim Preserve Errors(3, 0) As String
  Errors(0, 0) = 0

  'Call ParseEquation(EqString)
  Call ParseToArray(EqString)
  
  If Parsed Then
    Call Evaluate(1, EqLength, Value)
  End If
  
  'If no errors, retype original equation as parsed equation
  If Val(Errors(0, 0)) = 0 Then
    EqString = ""
    For ctr = 1 To EqLength
      Select Case Eq(1, ctr)
        Case "+"
          EqString = EqString + " + "
        Case "-"
          EqString = EqString + " - "
        Case Else
          EqString = EqString + Eq(1, ctr)
      End Select
    Next ctr
  End If
    ReDim ErrorCodes(Val(Errors(0, 0)), 2)
    ErrorCodes(0, 0) = Errors(0, 0)
    For ctr = 1 To Val(Errors(0, 0))
      For ctr2 = 0 To 1
        ErrorCodes(ctr, ctr2) = Errors(ctr2, ctr)
      Next ctr2
      For ctr2 = Val(Errors(2, ctr)) To Val(Errors(3, ctr))
        ErrorCodes(ctr, 2) = ErrorCodes(ctr, 2) + Eq(1, ctr2)
      Next ctr2
    Next ctr
  'End If
  If Not Parsed Then
    EqString = TempString
  End If
End Sub

Private Sub Evaluate(StartLoc As Integer, StopLoc As Integer, Value)
  Dim ContEval As Boolean
  Dim ContCheck As Boolean
  Dim OpenPar As Integer
  Dim ClosedPar As Integer
  Dim NumErrs As Integer
  Dim ctr As Integer
  Dim LeftValue As Single
  Dim RightValue As Single
  Dim TestChar As String
  
  ContEval = True
  
  'If enclosed in parentheses, check to make sure that only one expression, then
  'evaluate the expression in between
  If ContEval And (Eq(1, StartLoc) = "(" Or Eq(1, StartLoc) = "[") And (Eq(1, StopLoc) = ")" Or Eq(1, StopLoc) = "]") Then
    ContEval = False
    OpenPar = 0
    For ctr = StartLoc To (StopLoc - 1)
      Select Case Eq(1, ctr)
        Case "("
          OpenPar = OpenPar + 1
          
        Case ")"
          OpenPar = OpenPar - 1

        Case "["
          OpenPar = OpenPar + 1
          
        Case "]"
          OpenPar = OpenPar - 1
      End Select
      If OpenPar = 0 Then 'parentheses have enclosed an expression
        ContEval = True
      End If
    Next ctr
    If Not ContEval Then 'never found a parentheses enclosing an expression
      If StopLoc > (StartLoc + 1) Then
        Call Evaluate(StartLoc + 1, StopLoc - 1, Value)
      Else
        'Assign Error Code
        NumErrs = Val(Errors(0, 0))
        NumErrs = NumErrs + 1
        ReDim Preserve Errors(3, NumErrs)
        Errors(0, 0) = NumErrs
        Errors(0, NumErrs) = "02"
        Errors(1, NumErrs) = "Bad parentheses"
        Errors(2, NumErrs) = StartLoc
        Errors(3, NumErrs) = StopLoc
        Value = 1 'Standard value for an error
      End If
    End If
  End If
  
  'If only one element long, look to see if it's a number or a defined variable
  If ContEval And StartLoc = StopLoc Then
    If Eq(0, StartLoc) = "N" Then
      Value = Val(Eq(1, StartLoc))
    Else
      'Look for variables.  If not a defined variable, assign an error code
      NumErrs = Val(Errors(0, 0))
      NumErrs = NumErrs + 1
      ReDim Preserve Errors(3, NumErrs)
      Errors(0, 0) = NumErrs
      Errors(0, NumErrs) = "01"
      Errors(1, NumErrs) = "Variable not defined or character out of place"
      Errors(2, NumErrs) = StartLoc
      Errors(3, NumErrs) = StopLoc
      Value = 1 'Standard value for an error
    End If
    ContEval = False
  End If
  
  'Look for a + sign
  ctr = StartLoc - 1
  ContCheck = True
  OpenPar = 0
  Do While ContEval And ContCheck
    ctr = ctr + 1
    TestChar = Eq(1, ctr)
    Select Case Eq(1, ctr)
      Case "("
        OpenPar = OpenPar + 1
        
      Case ")"
        OpenPar = OpenPar - 1
        
      Case "["
        OpenPar = OpenPar + 1
        
      Case "]"
        OpenPar = OpenPar - 1
        
      Case "+"
        If OpenPar = 0 And ctr <> StartLoc Then
          Call Evaluate(StartLoc, ctr - 1, LeftValue)
          Call Evaluate(ctr + 1, StopLoc, RightValue)
          Value = LeftValue + RightValue
          ContEval = False
          ContCheck = False
        End If
    End Select

    If OpenPar < 0 Then
      'Assign Error Code
      NumErrs = Val(Errors(0, 0))
      NumErrs = NumErrs + 1
      ReDim Errors(3, NumErrs)
      Errors(0, 0) = NumErrs
      Errors(0, NumErrs) = "02"
      Errors(1, NumErrs) = "Bad parentheses"
      Errors(2, NumErrs) = StartLoc
      Errors(3, NumErrs) = StopLoc
      Value = 1 'Standard value for an error
    End If
    
    If ctr = (StopLoc - 1) Then  'Stop the loop at the character one before the end of the expression
      ContCheck = False
    End If
  Loop
  
  'Look for a - sign
  ctr = StartLoc - 1
  ContCheck = True
  OpenPar = 0
  Do While ContEval And ContCheck
    ctr = ctr + 1  'note that the first loop starts at the second character of the expression
    Select Case Eq(1, ctr)
      Case "("
        OpenPar = OpenPar + 1
        
      Case ")"
        OpenPar = OpenPar - 1
        
      Case "["
        OpenPar = OpenPar + 1
        
      Case "]"
        OpenPar = OpenPar - 1
        
      Case "-"
        If OpenPar = 0 And ctr <> StartLoc Then
          Call Evaluate(StartLoc, ctr - 1, LeftValue)
          Call Evaluate(ctr + 1, StopLoc, RightValue)
          Value = LeftValue - RightValue
          ContEval = False
          ContCheck = False
        End If
    End Select

    If OpenPar < 0 Then
      'Assign Error Code
      NumErrs = Val(Errors(0, 0))
      NumErrs = NumErrs + 1
      ReDim Preserve Errors(3, NumErrs)
      Errors(0, 0) = NumErrs
      Errors(0, NumErrs) = "02"
      Errors(1, NumErrs) = "Bad parentheses"
      Errors(2, NumErrs) = StartLoc
      Errors(3, NumErrs) = StopLoc
      Value = 1 'Standard value for an error
    End If
    
    If ctr = (StopLoc - 1) Then  'Stop the loop at the character one before the end of the expression
      ContCheck = False
    End If
  Loop
  
  'Look for a * sign
  ctr = StartLoc - 1
  ContCheck = True
  OpenPar = 0
  Do While ContEval And ContCheck
    ctr = ctr + 1  'note that the first loop starts at the second character of the expression
    TestChar = Eq(1, ctr)
    Select Case Eq(1, ctr)
      Case "("
        OpenPar = OpenPar + 1
        
      Case ")"
        OpenPar = OpenPar - 1

      Case "["
        OpenPar = OpenPar + 1
        
      Case "]"
        OpenPar = OpenPar - 1
        
      Case "*"
        If OpenPar = 0 And ctr <> StartLoc Then
          Call Evaluate(StartLoc, ctr - 1, LeftValue)
          Call Evaluate(ctr + 1, StopLoc, RightValue)
          LeftValue = LeftValue
          Value = LeftValue * RightValue
          ContEval = False
          ContCheck = False
        End If
    End Select

    If OpenPar < 0 Then
      Call Evaluate(StartLoc, ctr - 1, LeftValue)
      Call Evaluate(ctr + 1, StopLoc, RightValue)
      Value = LeftValue + RightValue
      ContEval = False
      ContCheck = False

      'Assign Error Code
      NumErrs = Val(Errors(0, 0))
      NumErrs = NumErrs + 1
      ReDim Preserve Errors(3, NumErrs)
      Errors(0, 0) = NumErrs
      Errors(0, NumErrs) = "02"
      Errors(1, NumErrs) = "Bad parentheses"
      Errors(2, NumErrs) = StartLoc
      Errors(3, NumErrs) = StopLoc
      Value = 1 'Standard value for an error
    End If
    
    If ctr = (StopLoc - 1) Then  'Stop the loop at the character one before the end of the expression
      ContCheck = False
    End If
  Loop
  
  'Look for a / sign
  ctr = StartLoc - 1
  ContCheck = True
  OpenPar = 0
  Do While ContEval And ContCheck
    ctr = ctr + 1  'note that the first loop starts at the second character of the expression
    Select Case Eq(1, ctr)
      Case "("
        OpenPar = OpenPar + 1
        
      Case ")"
        OpenPar = OpenPar - 1

      Case "["
        OpenPar = OpenPar + 1
        
      Case "]"
        OpenPar = OpenPar - 1
        
      Case "/"
        If OpenPar = 0 And ctr <> StartLoc Then
          Call Evaluate(StartLoc, ctr - 1, LeftValue)
          Call Evaluate(ctr + 1, StopLoc, RightValue)
          If RightValue <> 0 Then
  Value = LeftValue / RightValue
          Else
  'Assign Error Code
  NumErrs = Val(Errors(0, 0))
  NumErrs = NumErrs + 1
  ReDim Preserve Errors(3, NumErrs)
  Errors(0, 0) = NumErrs
  Errors(0, NumErrs) = "03"
  Errors(1, NumErrs) = "Divide By Zero"
  Errors(2, NumErrs) = StartLoc
  Errors(3, NumErrs) = StopLoc
  Value = 1 'Standard value for an error
          End If
          ContEval = False
          ContCheck = False
        End If
    End Select

    If OpenPar < 0 Then
      Call Evaluate(StartLoc, ctr - 1, LeftValue)
      Call Evaluate(ctr + 1, StopLoc, RightValue)
      Value = LeftValue + RightValue
      ContEval = False
      ContCheck = False

      'Assign Error Code
      NumErrs = Val(Errors(0, 0))
      NumErrs = NumErrs + 1
      ReDim Preserve Errors(3, NumErrs)
      Errors(0, 0) = NumErrs
      Errors(0, NumErrs) = "02"
      Errors(1, NumErrs) = "Bad parentheses"
      Errors(2, NumErrs) = StartLoc
      Errors(3, NumErrs) = StopLoc
      Value = 1 'Standard value for an error
    End If
    
    If ctr = (StopLoc - 1) Then  'Stop the loop at the character one before the end of the expression
      ContCheck = False
    End If
  Loop
  
  'Look for a ^
  ctr = StartLoc - 1
  ContCheck = True
  OpenPar = 0
  Do While ContEval And ContCheck
    ctr = ctr + 1  'note that the first loop starts at the second character of the expression
    TestChar = Eq(1, ctr)
    Select Case Eq(1, ctr)
      Case "("
        OpenPar = OpenPar + 1
        
      Case ")"
        OpenPar = OpenPar - 1

      Case "["
        OpenPar = OpenPar + 1
        
      Case "]"
        OpenPar = OpenPar - 1
        
      Case "^"
        If OpenPar = 0 And ctr <> StartLoc Then
          Call Evaluate(StartLoc, ctr - 1, LeftValue)
          Call Evaluate(ctr + 1, StopLoc, RightValue)
          Value = LeftValue ^ RightValue
          ContEval = False
          ContCheck = False
        End If
    End Select

    If OpenPar < 0 Then
      Call Evaluate(StartLoc, ctr - 1, LeftValue)
      Call Evaluate(ctr + 1, StopLoc, RightValue)
      Value = LeftValue + RightValue
      ContEval = False
      ContCheck = False

      'Assign Error Code
      NumErrs = Val(Errors(0, 0))
      NumErrs = NumErrs + 1
      ReDim Preserve Errors(3, NumErrs)
      Errors(0, 0) = NumErrs
      Errors(0, NumErrs) = "02"
      Errors(1, NumErrs) = "Bad parentheses"
      Errors(2, NumErrs) = StartLoc
      Errors(3, NumErrs) = StopLoc
      Value = 1 'Standard value for an error
    End If
    
    If ctr = (StopLoc - 1) Then  'Stop the loop at the character one before the end of the expression
      ContCheck = False
    End If
  Loop
  
  'Check StopLoc for !
  
  'Check to see if a standard function
  If ContEval Then
    TestChar = LCase(Eq(1, StartLoc))
    Select Case LCase(Eq(1, StartLoc))
      Case "sin"
        Eq(1, StartLoc) = LCase(Eq(1, StartLoc))
        Call Evaluate(StartLoc + 1, StopLoc, RightValue)
        Value = Sin(RightValue * 3.14159 / 180)
        ContEval = False
      Case "cos"
        Eq(1, StartLoc) = LCase(Eq(1, StartLoc))
        Call Evaluate(StartLoc + 1, StopLoc, RightValue)
        Value = Cos(RightValue * 3.14159 / 180)
        ContEval = False
      Case "tan"
        Eq(1, StartLoc) = LCase(Eq(1, StartLoc))
        Call Evaluate(StartLoc + 1, StopLoc, RightValue)
        Value = Tan(RightValue * 3.14159 / 180)
        ContEval = False
    End Select
  End If 'ContEval
  'Check to see if a user defined function
  
  'Error Code
  If ContEval Then
    NumErrs = Val(Errors(0, 0))
    NumErrs = NumErrs + 1
    ReDim Preserve Errors(3, NumErrs)
    Errors(0, 0) = NumErrs
    Errors(0, NumErrs) = "00"
    Errors(1, NumErrs) = "Bad Expression"
    Errors(2, NumErrs) = StartLoc
    Errors(3, NumErrs) = StopLoc
    Value = 1 'Standard value for an error
  End If
End Sub

Private Sub ParseEquation(EqString As String)
  Dim TestChar As String
  Dim CharType As String
  Dim PrevCharType As String
  Dim StringLength As Integer
  Dim ctrEquation As Integer
  Dim continueParsing As Boolean
  Dim ctr As Integer
  Dim ElementLength As Integer
  Dim continue As Boolean
  Dim DecimalCount As Integer
  Dim NumErrs As Integer
  
  StringLength = Len(EqString)
  ctrEquation = 0
  continueParsing = True
  ReDim Preserve Eq(2, 1)
  
  Do While continueParsing = True
    ctrEquation = ctrEquation + 1
    ReDim Preserve Eq(2, ctrEquation)
    ctr = 0
    ElementLength = 0
    continue = True
    DecimalCount = 0
    Parsed = True
   
    'Do the loop
    Do
      ctr = ctr + 1
      TestChar = LCase(Mid(EqString, ctr, 1))
      PrevCharType = CharType
      If Asc(TestChar) >= 97 And Asc(TestChar) <= 122 Then
        CharType = "L" 'letter
      ElseIf Asc(TestChar) >= 48 And Asc(TestChar) <= 57 Or TestChar = "." Or TestChar = "," Then
        CharType = "N" 'number
        If TestChar = "." Then
          DecimalCount = DecimalCount + 1
        End If
        If DecimalCount > 1 Then
          continue = False
          continueParsing = False
          NumErrs = Val(Errors(0, 0))
          NumErrs = NumErrs + 1
          ReDim Preserve Errors(3, NumErrs)
          Errors(0, 0) = NumErrs
          Errors(0, NumErrs) = "02"
          Errors(1, NumErrs) = "Invalid Number"
          Parsed = False
        End If
      Else
        CharType = "S" 'symbol
        continue = False
      End If
      If ctr > 1 And CharType <> PrevCharType Then
        continue = False
      End If
      If ctr = Len(EqString) Then
        continue = False
      End If
    Loop Until Not continue
    
    If ctr <> Len(EqString) Then
      If CharType = "S" And ctr = 1 Then
        Eq(0, ctrEquation) = PrevCharType
        Eq(1, ctrEquation) = Left(EqString, ctr)
        EqString = Right(EqString, Len(EqString) - ctr)
      Else
        Eq(0, ctrEquation) = PrevCharType
        Eq(1, ctrEquation) = Left(EqString, ctr - 1)
        EqString = Right(EqString, Len(EqString) - ctr + 1)
      End If
    ElseIf ctr = 1 Then 'only one character left
      Eq(0, ctrEquation) = CharType
      Eq(1, ctrEquation) = EqString
      continueParsing = False
    ElseIf PrevCharType = CharType Then 'two characters together are the same
      Eq(0, ctrEquation) = CharType
      Eq(1, ctrEquation) = Left(EqString, ctr)
      continueParsing = False
      'EqString = Right(EqString, Len(EqString))
    Else 'last character is different
      Eq(0, ctrEquation) = PrevCharType
      Eq(1, ctrEquation) = Left(EqString, ctr - 1)
      EqString = Right(EqString, Len(EqString) - ctr + 1)
      
      ctrEquation = ctrEquation + 1 'only one character left
      Eq(0, ctrEquation) = CharType
      Eq(1, ctrEquation) = EqString
      continueParsing = False
      'EqString = Right(EqString, Len(EqString) - ctr)
    End If
    If Len(EqString) = 0 Then
      continueParsing = False
    End If
  Loop
  EqLength = ctrEquation
  Eq(0, 0) = EqLength
  FormCalculator.TextDebug.Text = ""
  For ctr = 1 To EqLength
    FormCalculator.TextDebug.Text = FormCalculator.TextDebug.Text + Eq(0, ctr) + ", " + Eq(1, ctr) + vbCrLf
  Next ctr
End Sub

Private Sub ParseToArray(EqString As String)
  Dim TestChar As String
  Dim CharType As String
  Dim PrevCharType As String
  Dim StringLength As Integer
  Dim ctrEquation As Integer
  Dim continueEquation As Boolean
  Dim continueElement As Boolean
  Dim ctr As Integer
  Dim ElementLength As Integer
  Dim DecimalCount As Integer
  Dim NumErrs As Integer
  
  StringLength = Len(EqString)
  ctrEquation = 0
  continueEquation = True
  ReDim Preserve Eq(2, 1)
  
  Do While continueEquation = True
    ctrEquation = ctrEquation + 1
    ReDim Preserve Eq(2, ctrEquation)
    continueElement = True
    ctr = 0
    ElementLength = 0
    DecimalCount = 0
    Parsed = True
   
    'Do the loop
    Do While continueElement
      ctr = ctr + 1
      
      If ctr > Len(EqString) Then
        CharType = "EOE" 'End of Equation
        continueEquation = False
      Else
        TestChar = LCase(Mid(EqString, ctr, 1))
        If Asc(TestChar) >= 97 And Asc(TestChar) <= 122 Then
          CharType = "L" 'letter
        ElseIf Asc(TestChar) >= 48 And Asc(TestChar) <= 57 Or TestChar = "." Or TestChar = "," Then
          CharType = "N" 'number
          If TestChar = "." Then
  DecimalCount = DecimalCount + 1
          End If
          If DecimalCount > 1 Then
  continueElement = False
  continueEquation = False
  NumErrs = Val(Errors(0, 0))
  NumErrs = NumErrs + 1
  ReDim Preserve Errors(3, NumErrs)
  Errors(0, 0) = NumErrs
  Errors(0, NumErrs) = "02"
  Errors(1, NumErrs) = "Invalid Number"
  Parsed = False
          End If
        Else
          CharType = "S" 'symbol
        End If
      End If 'ctr > Len(EqString)

      If CharType <> PrevCharType And ctr > 1 Then
        continueElement = False
        Eq(0, ctrEquation) = PrevCharType
        Eq(1, ctrEquation) = Left(EqString, ctr - 1)
      ElseIf CharType = "S" Then
        continueElement = False
        Eq(0, ctrEquation) = CharType
        Eq(1, ctrEquation) = Left(EqString, ctr)
        ctr = ctr + 1 'adding one to make the shorten string line below work properly, without
            'having to have an if statement there
        If Len(EqString) = 1 Then
          CharType = "EOE"
          continueEquation = False
        End If
      End If
      PrevCharType = CharType
    Loop 'continueElement
    If CharType <> "EOE" Then
      EqString = Right(EqString, Len(EqString) - (ctr - 1))
    End If
  Loop 'continueEquation
  EqLength = ctrEquation
  Eq(0, 0) = EqLength
  FormCalculator.TextDebug.Text = ""
  For ctr = 1 To EqLength
    FormCalculator.TextDebug.Text = FormCalculator.TextDebug.Text + Eq(0, ctr) + ", " + Eq(1, ctr) + vbCrLf
  Next ctr
End Sub