Simple calculating function ?

When user type in "10*10+5" into a text box, how to display the result 105 in another text box or label control ? Remember that the number of operator in this string is not known.
LVL 1
HenryChanEAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

watyCommented:
' #VBIDEUtils#************************************************************
' * Programmer Name  : dragon/vb
' * Web Site         : http://personal.inet.fi/cool/dragon/vb/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 20/10/1999
' * Time             : 10:16
' **********************************************************************
' * Comments         : Equation evaluator class
' *
' *
' **********************************************************************
Option Explicit

'//
'// An equation evaluator class
'//
'// Description:
'// Evaluates mathematical expressions. All the standard mathematical
'// functions are included (sin, cos etc.). You can also add your own
'// functions.
'//
'// ***************************************************************
'// *  Go to Dragon's VB Code Corner for more useful sourcecode:  *
'// *  http://personal.inet.fi/cool/dragon/vb/                    *
'// ***************************************************************
'//
'// Author of this module: Unknown. Does anyone know who created this
'// great class?
'//
'
' It does a significant amount of work in the
' parsing of an equation, so it's more efficient
' when solving the same equation several times.
'
' The equation is not case sensitive.
'
'
' 1-1-96:  A Bug related to determining the difference between
'          a negative sign and negation was fixed. (And a priority
'          level PRI_NEG was added.)  - TPA
'
' 5-19-97: Updated to VB5.0.

'          Added user defined equations. (VB4.0 didn't allow calls
'          from within a function to the same function in another
'          instance of the class (Each call apparently used the
'          same local variable space.))
'
'          Minor bug fixes.
'
' 7-25-97: Increased the precision of the two conversion constants
'          DEG_TO_RAD and RAD_TO_DEG.  Also increased the precision
'          of the constant e.
'
'          Added the EQ_CLOSE_PAREN flag to the parse routine so that
'          parts in parenthesis would be treated as a number for
'          calculation, but so they aren't mistaken as a number. ie.
'          Fixes a bug when calculating things like (4+3)+23.
'          Also removed the isNeg flag since isNeg was always true
'          when t <> EQ_NONE after the EQ_CLOSE_PAREN flag was added.
'

Public Enum EquationErrors
   EquError_UnbalancedParen = 1100 ' Unbalanced parenthesis
   EquError_UnknownFunction        ' Unknown function
   EquError_UnknownVariable        ' Unknown variable
   EquError_InvalidEqu             ' Invalid Equation
   EquError_InvalidArg             ' Invalid argument to function
End Enum

Private Dirty As Boolean
Private Parsed As Boolean

Private Vars As Collection
Private Equs As Collection
Private Equ As String
Private Deg As Boolean

Private dAnswer As Double
Private EquParsed As Collection   'The parsed equation
Private EquOrder  As Collection   'Order in which to solve the equation

' Constants used in parsing
' Priority levels
Private Const PRI_ADD = 1
Private Const PRI_MOD = 2
Private Const PRI_MUL = 3
Private Const PRI_NEG = 4
Private Const PRI_EXP = 5
Private Const PRI_VAR = 6
Private Const PRI_PAR = 7
Private Const PRI_LEVEL = 7

Private Const EQ_NONE = 0
Private Const EQ_STRING = 1
Private Const EQ_NUMBER = 2
Private Const EQ_CLOSE_PAREN = 3

Private Const ER_NONE = 0
Private Const ER_VAR = 1

Private Const PI = 3.14159265358979
Private Const DEG_TO_RAD = 1.74532925199433E-02
Private Const RAD_TO_DEG = 57.2957795130824

Public Property Let Degrees(b As Boolean)
   If b <> Deg Then
      Deg = b
      Dirty = True
   End If
End Property

Public Property Get Degrees() As Boolean
   Degrees = Deg
End Property

Public Property Let Equation(e As String)
   Parsed = False
   Dirty = True
   Equ = LCase(e)
End Property

Public Property Get Equation() As String
   Equation = Equ
End Property

Public Property Set UserEqu(Name As String, eq As Equation)
   On Error Resume Next
   Dirty = True
   Equs.Remove Name & "("
   Equs.Add eq, Name & "("
End Property

Public Property Get UserEqu(Name As String) As Equation
   On Error GoTo GetError

   Set UserEqu = Equs(Name)
   Exit Property

GetError:
   Set UserEqu = Nothing
End Property

Public Sub UserEquClear()
   Set Equs = New Collection
   Dirty = True
End Sub

Public Sub UserEquRemove(Name As String)
   On Error Resume Next
   Equs.Remove Name & "("
   Dirty = True
End Sub

Public Sub VarClear()
   Set Vars = New Collection
   Dirty = True
End Sub

Public Sub VarRemove(Name As String)
   On Error Resume Next
   Vars.Remove Name
   Dirty = True
End Sub

Public Property Get Var(Name As String) As Double
   On Error GoTo GetError

   Var = CDbl(Vars(Name))
   Exit Property

GetError:
   Var = 0#
End Property

Public Property Let Var(Name As String, ByVal Num As Double)
   On Error Resume Next
   Dirty = True
   Vars.Remove Name
   Vars.Add Num, Name
End Property

' Internal search function...
Private Function GetRight(ByVal j As Long, v() As Variant) As Long
   Dim i As Long

   For i = j + 1 To UBound(v)
      If Not IsNull(v(i)) Then
         GetRight = i
         Exit Function
      End If
   Next i
   GetRight = 0
End Function
' Internal search function
Private Function GetLeft(ByVal j As Long, v() As Variant) As Long
   Dim i As Long

   For i = j - 1 To 1 Step -1
      If Not IsNull(v(i)) Then
         GetLeft = i
         Exit Function
      End If
   Next i
   GetLeft = 0
End Function

Public Function Value() As Double
   If Dirty Then
      Solve
   End If

   Value = dAnswer
End Function

Private Sub Class_Initialize()
   Dirty = False
   Parsed = True
   Degrees = False
   Set Vars = New Collection
   Set Equs = New Collection
End Sub

Private Sub Class_Terminate()
   Set Vars = Nothing
   Set Equs = Nothing
   Set EquParsed = Nothing
   Set EquOrder = Nothing
End Sub

Private Sub Parse()
   Dim i As Integer
   Dim s As String
   Dim t As Integer
   Dim j As Integer
   Dim sTmp As String
   Dim p As Integer
   Dim EquPriority As New Collection
   Dim maxPriority

   s = ""
   t = EQ_NONE
   j = 1
   p = 0
   Set EquParsed = New Collection

   EquParsed.Add ""
   EquPriority.Add ""
   maxPriority = PRI_LEVEL

   For i = 1 To Len(Equ)
      sTmp = Mid$(Equ, i, 1)

      Select Case sTmp
         Case "A" To "Z", "a" To "z", "_"
            If t = EQ_NONE Or t = EQ_CLOSE_PAREN Then
               t = EQ_STRING
               s = sTmp
            ElseIf t = EQ_NUMBER Then
               t = EQ_STRING
               EquParsed.Add s, , j
               EquPriority.Add 0, , j
               j = j + 1
               EquParsed.Add "*", , j
               EquPriority.Add PRI_MUL + p, , j
               j = j + 1
               s = sTmp
            Else
               s = s + sTmp
            End If

         Case "1" To "9", "0", "."
            If t = EQ_NONE Or t = EQ_CLOSE_PAREN Then
               t = EQ_NUMBER
               s = sTmp
            Else
               s = s + sTmp
            End If

         Case "(":
            If t = EQ_STRING Then
               EquParsed.Add s + sTmp, , j
               EquPriority.Add p + PRI_PAR, , j
               j = j + 1
               s = ""
            ElseIf t = EQ_NUMBER Then
               EquParsed.Add s, , j
               EquPriority.Add 0, , j
               j = j + 1
               EquParsed.Add "*", , j
               EquPriority.Add p + PRI_MUL, , j
               j = j + 1
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_PAR, , j
               j = j + 1
               s = ""
            Else
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_PAR, , j
               j = j + 1
            End If

            p = p + PRI_LEVEL
            t = EQ_NONE

            If maxPriority < p + PRI_LEVEL Then
               maxPriority = p + PRI_LEVEL
            End If

         Case "*", "/":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_MUL, , j
            j = j + 1
            t = EQ_NONE

         Case "/":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_MUL, , j
            j = j + 1
            t = EQ_NONE

         Case "+":
            If t <> EQ_NONE Then
               If t <> EQ_CLOSE_PAREN Then
                  EquParsed.Add s, , j
                  EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
                  j = j + 1
                  s = ""
               End If
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_ADD, , j
               j = j + 1
               t = EQ_NONE
            Else
               'Ignore things like "(+1)"
               t = EQ_NONE
            End If

         Case "-":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            'If we are preceded by a number, variable, or a closed
            'paren then we are a minus sign.
            If t <> EQ_NONE Then
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_ADD, , j
               j = j + 1
               t = EQ_NONE
            Else ' we are a negation sign
               EquParsed.Add "~", , j
               EquPriority.Add p + PRI_NEG, , j
               j = j + 1
               t = EQ_NONE
            End If

         Case "^":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_EXP, , j
            j = j + 1
            t = EQ_NONE

         Case "%":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_MOD, , j
            j = j + 1
            t = EQ_NONE

         Case ",":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            EquParsed.Add Null, , j
            EquPriority.Add 0, , j
            j = j + 1
            t = EQ_NONE

         Case ")":
            If t <> EQ_NONE And t <> EQ_CLOSE_PAREN Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If

            EquParsed.Add sTmp, , j
            EquPriority.Add p - (PRI_LEVEL - PRI_PAR), , j
            p = p - PRI_LEVEL
            j = j + 1
            t = EQ_CLOSE_PAREN
      End Select
   Next i

   If s <> "" Then
      EquParsed.Add s, , j
      EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
      j = j + 1
   End If

   EquParsed.Remove j
   EquPriority.Remove j

   If p <> 0 Then
      Err.Raise EquError_UnbalancedParen, "Equation", "Unbalanced parenthesis"
      Exit Sub
   End If

   'Debugging section...
   'For i = 1 To EquParsed.Count
   '   Debug.Print EquParsed(i) & ";";
   'Next i
   'Debug.Print
   '   For i = 1 To EquPriority.Count
   '   Debug.Print EquPriority(i) & ";";
   'Next i
   'Debug.Print
   'Debug.Print "MaxPriority = " & maxPriority
   ' End Debugging section....

   Set EquOrder = New Collection
   EquOrder.Add ""

   For j = 1 To maxPriority
      For i = EquPriority.Count To 1 Step -1
         If EquPriority(i) = j Then
            EquOrder.Add i, , , 1
         End If
      Next i
   Next j

   EquOrder.Remove 1

   'For i = 1 To EquOrder.Count
   '   Debug.Print EquOrder(i) & ";";
   'Next i
   'Debug.Print

   Parsed = True
End Sub

Public Sub Solve()
   Dim i As Long
   Dim j As Long
   Dim l As Long
   Dim r As Long
   Dim m As Long
   Dim n As Long
   Dim X As Double
   Dim Y As Double
   Dim v As Variant
   Dim eSpace As Integer
   Dim Temp() As Variant
   Dim f As Equation
   Dim j2 As Long  ' debug variable

   On Error GoTo SolveError

   If Not Parsed Then
      Parse
   End If

   ' Copy the equation to a working array
   ReDim Temp(1 To EquParsed.Count)

   For i = 1 To EquParsed.Count
      Temp(i) = EquParsed(i)
   Next

   eSpace = ER_NONE

   ' Solve the equation
   For i = 1 To EquOrder.Count
      'Debug.Print "Pro -> " & EquOrder(i) & " = ";
      'For j2 = 1 To UBound(Temp)
      '   Debug.Print Temp(j2) & ";";
      'Next j2
      'Debug.Print

      m = EquOrder(i)
      v = Temp(m)

      Select Case v
         ' Standard operators
         Case "~"  'Negative operator (inserted by the parser)
            r = GetRight(m, Temp)
            Temp(m) = -CDbl(Temp(r))
            Temp(r) = Null

         Case "*"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) * CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "/"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) / CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "/"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) / CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "+"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) + CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "-"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) - CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "^"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) ^ CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "%"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) Mod CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null

         Case "("
            i = i + 1
            n = EquOrder(i)
            r = GetRight(m, Temp)
            If r >= n Then
               Temp(m) = 0#
               Temp(n) = Null
            Else
               Temp(m) = Temp(r)
               Temp(r) = Null
               Temp(n) = Null
            End If

         Case Else
            If Right$(Temp(m), 1) = "(" Then
               'Must be a function
               i = i + 1
               n = EquOrder(i)

               l = GetRight(m, Temp)
               r = GetLeft(n, Temp)

               If l >= n Then
                  Err.Raise EquError_InvalidArg, "clsEquation", "Invalid arguments to function: " & v & ")"
                  Exit Sub
               Else
                  X = CDbl(Temp(l))
               End If

               If r <= m Then
                  Err.Raise EquError_InvalidArg, "clsEquation", "Invalid arguments to function: " & v & ")"
                  Exit Sub
               Else
                  Y = CDbl(Temp(r))
               End If

               Temp(r) = Null
               Temp(l) = Null
               Temp(m) = Null
               Temp(n) = Null

               Select Case v
                  ' Standard functions
                  Case "abs("
                     Temp(m) = Abs(X)

                  Case "atn("
                     If Degrees Then
                        Temp(m) = Atn(X) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X)
                     End If

                  Case "arctan("
                     If Degrees Then
                        Temp(m) = Atn(X) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X)
                     End If

                  Case "cos("
                     If Degrees Then
                        Temp(m) = Cos(X * DEG_TO_RAD)
                     Else
                        Temp(m) = Cos(X)
                     End If

                  Case "exp("
                     Temp(m) = Exp(X)

                  Case "fix("
                     Temp(m) = Fix(X)

                  Case "int("
                     Temp(m) = Int(X)

                  Case "log("
                     Temp(m) = Log(X)

                  Case "rnd("
                     Temp(m) = Rnd(X)

                  Case "sgn("
                     Temp(m) = Sgn(X)

                  Case "sin("
                     If Degrees Then
                        Temp(m) = Sin(X * DEG_TO_RAD)
                     Else
                        Temp(m) = Sin(X)
                     End If

                  Case "sqr("
                     Temp(m) = Sqr(X)

                  Case "tan("
                     If Degrees Then
                        Temp(m) = Tan(X * DEG_TO_RAD)
                     Else
                        Temp(m) = Tan(X)
                     End If

                     ' 2 variable functions
                  Case "min("
                     Temp(m) = IIf(X < Y, X, Y)

                  Case "max("
                     Temp(m) = IIf(X > Y, X, Y)

                  Case "random("
                     Temp(m) = (Rnd * (Y - X)) + X

                  Case "mod("
                     Temp(m) = X Mod Y

                  Case "logn("
                     Temp(m) = Log(X) / Log(Y)

                     ' Misc equations
                  Case "rand("
                     Temp(m) = Int(Rnd * X)

                     ' Derived functions
                  Case "sec("
                     If Degrees Then
                        Temp(m) = (1 / Cos(X * DEG_TO_RAD))
                     Else
                        Temp(m) = 1 / Cos(X)
                     End If

                  Case "cosec("
                     If Degrees Then
                        Temp(m) = (1 / Sin(X * DEG_TO_RAD))
                     Else
                        Temp(m) = 1 / Sin(X)
                     End If

                  Case "cotan("
                     If Degrees Then
                        Temp(m) = (1 / Tan(X * DEG_TO_RAD))
                     Else
                        Temp(m) = 1 / Tan(X)
                     End If

                  Case "arcsin("
                     If Degrees Then
                        Temp(m) = (Atn(X / Sqr(-X * X + 1))) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X / Sqr(-X * X + 1))
                     End If

                  Case "arccos("
                     If Degrees Then
                        Temp(m) = (Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
                     End If

                  Case "arcsec("
                     If Degrees Then
                        Temp(m) = (Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))
                     End If

                  Case "arccosec("
                     If Degrees Then
                        Temp(m) = (Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))
                     End If

                  Case "arccotan("
                     If Degrees Then
                        Temp(m) = (Atn(X * DEG_TO_RAD) + 2 * Atn(1)) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X) + 2 * Atn(1)
                     End If

                  Case "sinh("
                     Temp(m) = (Exp(X) - Exp(-X)) / 2

                  Case "cosh("
                     Temp(m) = (Exp(X) - Exp(-X)) / (Exp(X) + Exp(-X))

                  Case "tanh("
                     Temp(m) = (Exp(X) - Exp(-X)) / (Exp(X) + Exp(-X))

                  Case "sech("
                     Temp(m) = 2 / (Exp(X) + Exp(-X))

                  Case "cosech("
                     Temp(m) = 2 / (Exp(X) - Exp(-X))

                  Case "cotanh("
                     Temp(m) = (Exp(X) + Exp(-X)) / (Exp(X) - Exp(-X))

                  Case "arcsinh("
                     Temp(m) = Log(X + Sqr(X * X + 1))

                  Case "arccosh("
                     Temp(m) = Log(X + Sqr(X * X - 1))

                  Case "arctanh("
                     Temp(m) = Log((1 + X) / (1 - X)) / 2

                  Case "arcsech("
                     Temp(m) = Log((Sqr(-X * X + 1) + 1) / X)

                  Case "arccosech("
                     Temp(m) = Log((Sgn(X) * Sqr(X * X + 1) + 1) / X)

                  Case "arccotanh("
                     Temp(m) = Log((X + 1) / (X - 1)) / 2

                  Case "log10("
                     Temp(m) = Log(X) / Log(10)

                  Case "log2("
                     Temp(m) = Log(X) / Log(2)

                  Case "ln("    'A macro to Log
                     Temp(m) = Log(X)

                     ' conversion functions
                  Case "deg("   ' Radians to degrees
                     Temp(m) = X * RAD_TO_DEG

                  Case "rad("   ' Degrees to radians
                     Temp(m) = X * DEG_TO_RAD

                  Case Else
                     'check for user defined equ's
                     On Error Resume Next
                     Set f = Equs(v)
                     If Err = 0 Then
                        On Error GoTo SolveError
                        f.Var("x") = X
                        f.Var("y") = Y
                        Temp(m) = f.Value
                     Else
                        Err.Raise EquError_InvalidEqu, "clsEquation", "Undefined Function: " & v & ")"
                        Exit Sub
                     End If
               End Select
            Else
               'Must be a variable
               Select Case v
                  Case "pi":
                     Temp(m) = PI

                  Case "e":
                     Temp(m) = Exp(1)

                  Case "rnd":
                     Temp(m) = Rnd

                  Case Else
                     eSpace = ER_VAR
                     Temp(m) = CDbl(Vars(Temp(m)))
                     eSpace = ER_NONE
               End Select
            End If
      End Select
   Next i

   dAnswer = CDbl(Temp(GetRight(0, Temp)))
   Dirty = False
   Exit Sub

SolveError:
   Select Case Err
      'Overflow, division by 0, internal errors...
      Case 6, 11, EquError_UnbalancedParen To EquError_InvalidArg
         Err.Raise Err, "clsEquation", Err.Description
      Case 5:
         Select Case eSpace
            Case ER_VAR
               Err.Raise EquError_UnknownVariable, "clsEquation", "Undefined Variable: " & v
            Case Else
               Err.Raise Err, "clsEquation", Err.Description
         End Select
      Case Else
         Err.Raise EquError_InvalidEqu, "clsEquation", "Invalid Equation"
   End Select
End Sub
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
watyCommented:
' #VBIDEUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 28/06/99
' * Time             : 12:45
' **********************************************************************
' * Comments         : Equation Solver
' *
' *
' **********************************************************************

Option Explicit

' An equation solver class.
' Probably not really quick, but it's all VBasic code.
'
' It does a significant amount of work in the
' parsing of an equation, so it's more efficient
' when solving the same equation several times.
'
' The equation is not case sensitive.
'
'
' 1-1-96: A Bug related to determining the difference between
'         a negative sign and negation was fixed. (And a priority
'         level PRI_NEG was added.)  - TPA
'

'Error defines for clsEquation

Const EQ_PAREN = 1100     ' Unbalanced parenthesis
Const EQ_FUNCTION = 1101  ' Unknown function:
Const EQ_VARIABLE = 1102  ' Unknown variable:
Const EQ_INVALID = 1103   ' Invalid Equation
Const EQ_ARGS = 1104      ' Invalids arguments to function:
Const EQ_NAME = 1105      ' Unable to add an unnamed function:

Private Dirty As Boolean
Private Parsed As Boolean

Private Vars As New Collection
Private Equ As String
Private Deg As Boolean

Private dAnswer As Double
Private EquParsed As Collection   'The parsed equation
Private EquOrder  As Collection   'Order in which to solve the equation


' Constants used in parsing
' Priority levels
Private Const PRI_ADD = 1
Private Const PRI_MOD = 2
Private Const PRI_MUL = 3
Private Const PRI_NEG = 4
Private Const PRI_EXP = 5
Private Const PRI_VAR = 6
Private Const PRI_PAR = 7
Private Const PRI_LEVEL = 7

Private Const EQ_NONE = 0
Private Const EQ_STRING = 1
Private Const EQ_NUMBER = 2

Private Const ER_NONE = 0
Private Const ER_VAR = 1

Private Const PI = 3.14159265358979
Private Const DEG_TO_RAD = 0.01745329251995
Private Const RAD_TO_DEG = 57.2957795131

Public Property Let Degrees(b As Boolean)
   If b <> Deg Then
      Deg = b
      Dirty = True
   End If
End Property

Public Property Get Degrees() As Boolean
   Degrees = Deg
End Property

Private Function GetRight(ByVal j As Long, v() As Variant) As Long
   Dim i As Long
   
   For i = j + 1 To UBound(v)
      If Not IsNull(v(i)) Then
         GetRight = i
         Exit Function
      End If
   Next i
   GetRight = 0
End Function

Private Function GetLeft(ByVal j As Long, v() As Variant) As Long
   Dim i As Long
   
   For i = j - 1 To 1 Step -1
      If Not IsNull(v(i)) Then
         GetLeft = i
         Exit Function
      End If
   Next i
   GetLeft = 0
End Function
Public Sub VarClear()
   Set Vars = New Collection
   Dirty = True
End Sub


Public Property Let Equation(e As String)
   Parsed = False
   Dirty = True
   Equ = LCase(e)
End Property

Public Property Get Equation() As String
   Equation = Equ
End Property

Private Sub Parse()
   Dim i As Integer
   Dim s As String
   Dim t As Integer
   Dim j As Integer
   Dim sTmp As String
   Dim p As Integer
   Dim EquPriority As New Collection
   Dim maxPriority
   Dim isNeg As Boolean
   
   s = ""
   t = EQ_NONE
   j = 1
   p = 0
   isNeg = False
   Set EquParsed = New Collection
   
   EquParsed.Add ""
   EquPriority.Add ""
   maxPriority = PRI_LEVEL
   
   For i = 1 To Len(Equ)
      sTmp = Mid$(Equ, i, 1)
     
      Select Case sTmp
         Case "A" To "Z", "a" To "z", "_"
            If t = EQ_NONE Then
               t = EQ_STRING
               s = sTmp
            ElseIf t = EQ_NUMBER Then
               t = EQ_STRING
               EquParsed.Add s, , j
               EquPriority.Add 0, , j
               j = j + 1
               EquParsed.Add "*", , j
               EquPriority.Add PRI_MUL + p, , j
               j = j + 1
               s = sTmp
            Else
               s = s + sTmp
            End If
            isNeg = True
           
         Case "1" To "9", "0", "."
            If t = EQ_NONE Then
               t = EQ_NUMBER
               s = sTmp
            Else
               s = s + sTmp
            End If
            isNeg = True
           
         Case "(":
            If t = EQ_STRING Then
               EquParsed.Add s + sTmp, , j
               EquPriority.Add p + PRI_PAR, , j
               j = j + 1
               s = ""
            ElseIf t = EQ_NUMBER Then
               EquParsed.Add s, , j
               EquPriority.Add 0, , j
               j = j + 1
               EquParsed.Add "*", , j
               EquPriority.Add p + PRI_MUL, , j
               j = j + 1
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_PAR, , j
               j = j + 1
               s = ""
            Else
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_PAR, , j
               j = j + 1
            End If
           
            p = p + PRI_LEVEL
            t = EQ_NONE
           
            If maxPriority < p + PRI_LEVEL Then
               maxPriority = p + PRI_LEVEL
            End If
            isNeg = False
           
         Case "*", "/":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_MUL, , j
            j = j + 1
            t = EQ_NONE
            isNeg = False
           
         Case "\":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_MUL, , j
            j = j + 1
            t = EQ_NONE
            isNeg = False
           
         Case "+":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_ADD, , j
               j = j + 1
               t = EQ_NONE
            Else
               'Ignore things like "(+1)"
            End If
            isNeg = False
           
         Case "-":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            If isNeg Then
               EquParsed.Add sTmp, , j
               EquPriority.Add p + PRI_ADD, , j
               j = j + 1
               t = EQ_NONE
            Else
               EquParsed.Add "~", , j
               EquPriority.Add p + PRI_NEG, , j
               j = j + 1
               t = EQ_NONE
            End If
           
            isNeg = False
           
         Case "^":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_EXP, , j
            j = j + 1
            t = EQ_NONE
            isNeg = False
           
         Case "%":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            EquParsed.Add sTmp, , j
            EquPriority.Add p + PRI_MOD, , j
            j = j + 1
            t = EQ_NONE
            isNeg = False
           
         Case ",":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            EquParsed.Add Null, , j
            EquPriority.Add 0, , j
            j = j + 1
            t = EQ_NONE
            isNeg = False
           
         Case ")":
            If t <> EQ_NONE Then
               EquParsed.Add s, , j
               EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
               j = j + 1
               s = ""
            End If
           
            EquParsed.Add sTmp, , j
            EquPriority.Add p - (PRI_LEVEL - PRI_PAR), , j
            p = p - PRI_LEVEL
            j = j + 1
            t = EQ_NONE
            isNeg = True
      End Select
   Next i
   
   If s <> "" Then
      EquParsed.Add s, , j
      EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
      j = j + 1
   End If
   
   EquParsed.Remove j
   EquPriority.Remove j
   
   If p <> 0 Then
      Err.Raise EQ_PAREN, "clsEquation", "Unbalanced parenthesis"
      Exit Sub
   End If
   
   ' Debugging section...
   'For i = 1 To EquParsed.Count
   '   Debug.Print EquParsed(i) & ";";
   'Next i
   'Debug.Print
   '   For i = 1 To EquPriority.Count
   '   Debug.Print EquPriority(i) & ";";
   'Next i
   'Debug.Print
   'Debug.Print "MaxPriority = " & maxPriority
   ' End Debugging section....
   
   Set EquOrder = New Collection
   EquOrder.Add ""
   
   For j = 1 To maxPriority
      For i = EquPriority.Count To 1 Step -1
         If EquPriority(i) = j Then
            EquOrder.Add i, , , 1
         End If
      Next i
   Next j
   
   EquOrder.Remove 1
   
   'For i = 1 To EquOrder.Count
   '   Debug.Print EquOrder(i) & ";";
   'Next i
   'Debug.Print
   
   Parsed = True
End Sub

Public Sub VarRemove(Name As String)
   On Error Resume Next
   Vars.Remove Name
   Dirty = True
End Sub

Public Function Solution() As Double
   If Dirty Then
      Solve
   End If
   
   Solution = dAnswer
End Function

Public Sub Solve()
   Dim i As Long
   Dim j As Long
   Dim l As Long
   Dim r As Long
   Dim m As Long
   Dim n As Long
   Dim X As Double
   Dim Y As Double
   Dim v As Variant
   Dim eSpace As Integer
   Dim Temp() As Variant
   Dim f As clsEquation
   Dim j2 As Long  ' debug variable
   
   On Error GoTo SolveError
   
   If Not Parsed Then
      Parse
   End If
   
   ' Copy the equation to a working array
   ReDim Temp(1 To EquParsed.Count)
   
   For i = 1 To EquParsed.Count
      Temp(i) = EquParsed(i)
   Next
   
   eSpace = ER_NONE
   
   ' Solve the equation
   For i = 1 To EquOrder.Count
      'Debug.Print "Pro -> " & EquOrder(i) & " = ";
      'For j2 = 1 To UBound(Temp)
      '   Debug.Print Temp(j2) & ";";
      'Next j2
      'Debug.Print
     
      m = EquOrder(i)
      v = Temp(m)
     
      Select Case v
         ' Standard operators
         Case "~"  'Negative operator (inserted by the parser)
            r = GetRight(m, Temp)
            Temp(m) = -CDbl(Temp(r))
            Temp(r) = Null
           
         Case "*"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) * CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "/"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) / CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "\"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) \ CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "+"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) + CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "-"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) - CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "^"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) ^ CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "%"
            l = GetLeft(m, Temp)
            r = GetRight(m, Temp)
            Temp(l) = CDbl(Temp(l)) Mod CDbl(Temp(r))
            Temp(r) = Null
            Temp(m) = Null
           
         Case "("
            i = i + 1
            n = EquOrder(i)
            r = GetRight(m, Temp)
            If r >= n Then
               Temp(m) = 0#
               Temp(n) = Null
            Else
               Temp(m) = Temp(r)
               Temp(r) = Null
               Temp(n) = Null
            End If
           
         Case Else
            If Right$(Temp(m), 1) = "(" Then
               'Must be a function
               i = i + 1
               n = EquOrder(i)
               
               l = GetRight(m, Temp)
               r = GetLeft(n, Temp)
               
               If l >= n Then
                  Err.Raise EQ_ARGS, "clsEquation", "Invalid arguments to function: " & v & ")"
                  Exit Sub
               Else
                  X = CDbl(Temp(l))
               End If
               
               If r <= m Then
                  Err.Raise EQ_ARGS, "clsEquation", "Invalid arguments to function: " & v & ")"
                  Exit Sub
               Else
                  Y = CDbl(Temp(r))
               End If
               
               Temp(r) = Null
               Temp(l) = Null
               Temp(m) = Null
               Temp(n) = Null
               
               Select Case v
                  ' Standard functions
                  Case "abs("
                     Temp(m) = Abs(X)
                     
                  Case "atn("
                     If Degrees Then
                        Temp(m) = Atn(X) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X)
                     End If
                     
                  Case "arctan("
                     If Degrees Then
                        Temp(m) = Atn(X) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X)
                     End If
                     
                  Case "cos("
                     If Degrees Then
                        Temp(m) = Cos(X * DEG_TO_RAD)
                     Else
                        Temp(m) = Cos(X)
                     End If
                     
                  Case "exp("
                     Temp(m) = Exp(X)
                     
                  Case "fix("
                     Temp(m) = Fix(X)
                     
                  Case "int("
                     Temp(m) = Int(X)
                     
                  Case "log("
                     Temp(m) = Log(X)
                     
                  Case "rnd("
                     Temp(m) = Rnd(X)
                     
                  Case "sgn("
                     Temp(m) = Sgn(X)
                     
                  Case "sin("
                     If Degrees Then
                        Temp(m) = Sin(X * DEG_TO_RAD)
                     Else
                        Temp(m) = Sin(X)
                     End If
                     
                  Case "sqr("
                     Temp(m) = Sqr(X)
                     
                  Case "tan("
                     If Degrees Then
                        Temp(m) = Tan(X * DEG_TO_RAD)
                     Else
                        Temp(m) = Tan(X)
                     End If
                     
                     ' 2 variable functions
                  Case "min("
                     Temp(m) = IIf(X < Y, X, Y)
                     
                  Case "max("
                     Temp(m) = IIf(X > Y, X, Y)
                     
                  Case "random("
                     Temp(m) = (Rnd * (Y - X)) + X
                     
                  Case "mod("
                     Temp(m) = X Mod Y
                     
                  Case "logn("
                     Temp(m) = Log(X) / Log(Y)
                     
                     ' Misc equations
                  Case "rand("
                     Temp(m) = Int(Rnd * X)
                     
                     ' Derived functions
                  Case "sec("
                     If Degrees Then
                        Temp(m) = (1 / Cos(X * DEG_TO_RAD))
                     Else
                        Temp(m) = 1 / Cos(X)
                     End If
                     
                  Case "cosec("
                     If Degrees Then
                        Temp(m) = (1 / Sin(X * DEG_TO_RAD))
                     Else
                        Temp(m) = 1 / Sin(X)
                     End If
                     
                  Case "cotan("
                     If Degrees Then
                        Temp(m) = (1 / Tan(X * DEG_TO_RAD))
                     Else
                        Temp(m) = 1 / Tan(X)
                     End If
                     
                  Case "arcsin("
                     If Degrees Then
                        Temp(m) = (Atn(X / Sqr(-X * X + 1))) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X / Sqr(-X * X + 1))
                     End If
                     
                  Case "arccos("
                     If Degrees Then
                        Temp(m) = (Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
                     End If
                     
                  Case "arcsec("
                     If Degrees Then
                        Temp(m) = (Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))
                     End If
                     
                  Case "arccosec("
                     If Degrees Then
                        Temp(m) = (Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * (2 * Atn(1))
                     End If
                     
                  Case "arccotan("
                     If Degrees Then
                        Temp(m) = (Atn(X * DEG_TO_RAD) + 2 * Atn(1)) * RAD_TO_DEG
                     Else
                        Temp(m) = Atn(X) + 2 * Atn(1)
                     End If
                     
                  Case "sinh("
                     Temp(m) = (Exp(X) - Exp(-X)) / 2
                     
                  Case "cosh("
                     Temp(m) = (Exp(X) - Exp(-X)) / (Exp(X) + Exp(-X))
                     
                  Case "tanh("
                     Temp(m) = (Exp(X) - Exp(-X)) / (Exp(X) + Exp(-X))
                     
                  Case "sech("
                     Temp(m) = 2 / (Exp(X) + Exp(-X))
                     
                  Case "cosech("
                     Temp(m) = 2 / (Exp(X) - Exp(-X))
                     
                  Case "cotanh("
                     Temp(m) = (Exp(X) + Exp(-X)) / (Exp(X) - Exp(-X))
                     
                  Case "arcsinh("
                     Temp(m) = Log(X + Sqr(X * X + 1))
                     
                  Case "arccosh("
                     Temp(m) = Log(X + Sqr(X * X - 1))
                     
                  Case "arctanh("
                     Temp(m) = Log((1 + X) / (1 - X)) / 2
                     
                  Case "arcsech("
                     Temp(m) = Log((Sqr(-X * X + 1) + 1) / X)
                     
                  Case "arccosech("
                     Temp(m) = Log((Sgn(X) * Sqr(X * X + 1) + 1) / X)
                     
                  Case "arccotanh("
                     Temp(m) = Log((X + 1) / (X - 1)) / 2
                     
                  Case "log10("
                     Temp(m) = Log(X) / Log(10)
                     
                  Case "log2("
                     Temp(m) = Log(X) / Log(2)
                     
                  Case "ln("    'A macro to Log
                     Temp(m) = Log(X)
                     
                     ' conversion functions
                  Case "deg("   ' Radians to degrees
                     Temp(m) = X * RAD_TO_DEG
                     
                  Case "rad("   ' Degrees to radians
                     Temp(m) = X * DEG_TO_RAD
                     
                  Case Else
                     Err.Raise EQ_FUNCTION, "clsEquation", "Undefined Function: " & v & ")"
                     Exit Sub
               End Select
            Else
               'Must be a variable
               Select Case v
                  Case "pi":
                     Temp(m) = PI
                     
                  Case "e":
                     Temp(m) = 2.718281828
                     
                  Case "rnd":
                     Temp(m) = Rnd
                     
                  Case Else
                     eSpace = ER_VAR
                     Temp(m) = CDbl(Vars(Temp(m)))
                     eSpace = ER_NONE
               End Select
            End If
      End Select
   Next i
   
   dAnswer = CDbl(Temp(GetRight(0, Temp)))
   Dirty = False
   Exit Sub
   
SolveError:
   Select Case Err
      'Overflow, division by 0, internal errors...
      Case 6, 11, EQ_PAREN To EQ_NAME
         Err.Raise Err, "clsEquation", Err.Description
      Case 5:
         Select Case eSpace
            Case ER_VAR
               Err.Raise EQ_VARIABLE, "clsEquation", "Undefined Variable: " & v
            Case Else
               Err.Raise Err, "clsEquation", Err.Description
         End Select
      Case Else
         Err.Raise EQ_INVALID, "clsEquation", "Invalid Equation"
   End Select
End Sub

Public Property Get Var(Name As String) As Double
   On Error GoTo GetError
   
   Var = CDbl(Vars(Name))
   Exit Property
   
GetError:
   Var = 0#
End Property

Public Property Let Var(Name As String, Num As Double)
   On Error Resume Next
   Dirty = True
   Vars.Remove Name
   Vars.Add Num, Name
End Property

Private Sub Class_Initialize()
   Dirty = False
   Parsed = True
   Degrees = False
End Sub


0
watyCommented:
' #VBIDEUtils#************************************************************
' * Programmer Name  : Tretyakov Konstantin
' * Web Site         : http://www.planet-source-code.com/vb/ftp/CODE_UPLOAD227312131999.zip
' * E-Mail           : kt_ee@yahoo.com
' * Date             : 15/12/1999
' * Time             : 12:58
' **********************************************************************
' * Comments         : Expression Evaluator
' *
' *
' **********************************************************************
'Copyright© 1999, Tretyakov Konstantin
'_____________________________________________________
'This is the 'Evaluator' class: it inputs a string
'like "2+2" or "2+4*sin(3.4)^2-8*arccos(0.55)", etc
'_____________________________________________________
'You may use the code for free, if you give me credit.
'If you modify it or make your own program with it,
'I would VERY APPRECIATE, if you mail me it (or better-
'a link to it)
'On the whole - just do not stamp your name on what you haven't
'done quite alone.
'This code was written totally by me, and 'it took me about
'2 days to code it (and about a year
'-that is,from the very moment I got interested in programming-
'I spent dreaming of having such a thing)

'(BTW this code seems to be quite unique-
'I searched all over the Internet for such, but NOONE
'is giving the source for such things)
'______________________________________________________
'Yours Sincerely, Konstantin Tretyakov (kt_ee@yahoo.com)

'********************Here we go...********************
'Well, at the very beginning (when I had only + and -)
'These constants didplay a role:
'e.g. I could change the PLUS_SIGN to "plus"
'and the MINUS_SIGN to "minus", so that I could
'write an expression like "1 plus 2 minus 3"
'But now it will not go. :(
Const PLUS_SIGN = "+"
Const MINUS_SIGN = "-"
Const MULTIPLY_SIGN = "*"
Const DIVIDE_SIGN = "/"
Const POWER_SIGN = "^"
Const POINT_SIGN = ","
Const BRACKET_LEFT = "("
Const BRACKET_RIGHT = ")"

'This is the part to be improved - I mean this error-handling
Public Enum EvalError
   ERR_NONE = 0
   ERR_DBL_POINT = 1
   ERR_WRONG_SYNTAX = 2
   ERR_WRONG_SIGN = 4
   ERR_WRONG_BRACKETS = 8
   ERR_WRONG_FUNCTION = 16
End Enum

'This entry was needed for my other project - Function Analyzer
'(look for it at the same place, where you found this one)
Private m_Assigned As Boolean
'I hope you get, what these do
Private m_Expression As String
Private m_Result As Double
Private m_Error As EvalError

Public Property Let Expression(ByVal NewExpr As String)
   m_Expression = ReplaceText(UCase(RemoveSpaces(NewExpr)), ".", POINT_SIGN)
End Property
Public Property Get Expression() As String
   Expression = m_Expression
End Property
Public Property Get Error() As EvalError
   Error = m_Error
End Property

Public Property Get Result() As Double
   'Reset the Error
   m_Error = ERR_NONE
   'Calculate
   m_Result = Eval(m_Expression)
   m_Assigned = (m_Error = ERR_NONE)
   'Return
   Result = m_Result
End Property
Public Property Get Assigned() As Boolean
   Assigned = m_Assigned
End Property
Public Function Evaluate(ByVal Expressn As String, Optional ByVal Silent As Boolean = False) As Double
   'That's the wrapper for the main procedure
   'You may use this class in 2 ways:
   '1) Set the 'Expression' property and then read the 'Result' property
   '2) Call this sub. If you set Silent to False, then the sub will generate a message automatically
   Dim Res As Double
   Expression = Expressn
   Res = Result
   If Not Silent Then
      If m_Error <> ERR_NONE Then
         Select Case m_Error
            Case ERR_DBL_POINT:  MsgBox "Error: Wrong decimal separator placement!", vbCritical, "Eval Error"
            Case ERR_WRONG_BRACKETS: MsgBox "Error: Wrong bracket placement!", vbCritical, "Eval Error"
            Case ERR_WRONG_SIGN: MsgBox "Error: Wrong sign or bracket placement!", vbCritical, "Eval Error"
            Case ERR_WRONG_SYNTAX: MsgBox "Error: Wrong syntax!", vbCritical, "Eval Error"
         End Select
      Else
         MsgBox "Result: " & Res, vbExclamation, "Eval Result"
      End If
   End If
   Evaluate = m_Result
End Function

'***********************************************************
' 2 helper functions, well they are too 'universal' for this class
' (Here we use them only to remove spaces and replace the '.' to ','

Private Function RemoveSpaces(S$) As String
   RemoveSpaces = ReplaceText(S$)
End Function

Public Function ReplaceText(ByVal SourceText$, Optional ByVal StrToReplace$ = " ", Optional ByVal StrToInsert$ = "") As String
   Dim RetS$, I%
   If StrToReplace = StrToInsert Or StrToReplace = "" Then Exit Function
   RetS = SourceText$
   I = InStr(RetS, StrToReplace)
   Do While I <> 0
      RetS = IIf(I = 1, "", Left(RetS, I - 1)) & StrToInsert$ & IIf(I = Len(RetS) - Len(StrToReplace) + 1, "", Right(RetS, Len(RetS) - I - Len(StrToReplace) + 1))
      I = InStr(RetS, StrToReplace)
   Loop
   ReplaceText = RetS
End Function
'***********************************************************

'The HEART of the class.
'What it does? - it just splits the expression to monomials
'(that is: 2*3+3^(3-2)-(2+3) has 3 monomials:
'      +2*3,  +3^(3-2)  -(2+3)
'Then it calls the CalcMonomial for each and sums the result

Private Function Eval(ByVal Expr As String) As Double
   Dim sEval$, I&, MonomArray As Variant, dResult As Double
   sEval = Expr
   MonomArray = SplitToMonomials(sEval)
   For I = LBound(MonomArray) To UBound(MonomArray)
      dResult = dResult + CalcMonomial(MonomArray(I))
   Next
   Eval = dResult
End Function

Private Function SplitToMonomials(ByVal EvalStr As String, Optional ByVal Sign1 As String = PLUS_SIGN, Optional ByVal Sign2 As String = MINUS_SIGN) As Variant
   'Divides the given string in parts using the given sign (Sign1 and Sign2) parameter

   'Returns an array where each item is a string
   'For example SplitToMonomials("2+3*8-4","+","-") returns [2, +3*8, -4]
   '        and SplitToMonomials("3*2/23","*","/") returns [3, *2, /23]

   'The function also doesn't split brackets so that
   '      SplitToMonominals("(3+2)*2-3","+","-") will return [(3+2)*2, -3]

   Dim MonomArray As Variant, I&, Count&
   Dim CurMonom As String, sEval As String
   ReDim MonomArray(0)
   sEval = EvalStr
   'Find the first PLUS or MINUS (MUL or DIV) that are not in Bracket
   '(GetSplitPos is Just an Improved Instr, that considers brackets)
   I = GetSplitPos(EvalStr, Sign1, Sign2)
   Do While I > 0
      'NOT DONE:
      'Check for expressions of a kind: "2-3*4+6*-5"
      'because we must not split between 6 and 5
      CurMonom = Left(sEval, I - 1)
      'Populate the Array
      ReDim Preserve MonomArray(Count)
      MonomArray(Count) = CurMonom
      Count = Count + 1
      sEval = Mid(sEval, I)
      I = GetSplitPos(sEval, Sign1, Sign2)
   Loop

   CurMonom = sEval
   ReDim Preserve MonomArray(Count)
   MonomArray(Count) = CurMonom
   SplitToMonomials = MonomArray
End Function

'Calculates a monomial (expression without PLUSes and MINUSes inside)
'The work is in fact like of the Eval function:
'We split it to smaller parts (the ones, that may contain only the ^ sign)
'and then Calculate each part separately
Private Function CalcMonomial(ByVal Monomial As String) As Double
   On Error GoTo ErrCalcMember
   If m_Error <> ERR_NONE Then Exit Function
   Dim MemberArray As Variant, Sign As String
   Dim I&, dResult As Double, TempRes As Double
   'Split again, but now by * and /
   MemberArray = SplitToMonomials(Monomial, MULTIPLY_SIGN, DIVIDE_SIGN)
   For I = LBound(MemberArray) To UBound(MemberArray)
      TempRes = CalcMember(MemberArray(I), Sign)
      Select Case Sign
         'Remember - we may have the Plus_sign left in a monomial
         '(like a monomial may be "+2^2*3")
         Case PLUS_SIGN: dResult = dResult + TempRes
         Case MULTIPLY_SIGN: dResult = dResult * TempRes
         Case DIVIDE_SIGN:  dResult = dResult / TempRes
      End Select
   Next
   CalcMonomial = dResult
   Exit Function
ErrCalcMember:
   m_Error = ERR_WRONG_FUNCTION
End Function

'Calculates an expression, that contains only the operands
'higher in proirity than * and /

'TODO: It raises an error on X^Y^Z and calculates only X^Y,
'That is, for correct calculation you must specify either (X^Y)^Z
'or X^(Y^Z) (btw which is right ???)
Private Function CalcMember(ByVal Member As String, ByRef Sign As String) As Double
   Dim sSign As String, sEval As String, HaveMinus As Boolean, GotNum1 As Boolean
   Dim Num1 As Double, Num2 As Double, Op As String, dResult As Double
   Dim Func As String, FuncExpr As String
   If m_Error <> ERR_NONE Then Exit Function
   'Here we calculate the results of operations
   'whose priority is higher than * and /
   'The sample given string may be: "+5^2", "*4^2", "/6", "6^2,3"
   'or +(expr)^2, or (expr)^(expr)
   Sign = PLUS_SIGN
   sEval = Member
   sSign = Left(sEval, 1)
   'Determine the Sign (or find the Bracket or a function)
   If Not IsNumeric(sSign) Then
      Select Case sSign
         Case MINUS_SIGN
            HaveMinus = True
            sEval = Mid(sEval, 2)
            If Left(sEval, 1) = BRACKET_LEFT Then GoTo LBrack
            If IsNumeric(Left(sEval, 1)) = False Then GoTo HaveFunc
         Case PLUS_SIGN, MULTIPLY_SIGN, DIVIDE_SIGN
            Sign = sSign
            sEval = Mid(sEval, 2)
            If Left(sEval, 1) = BRACKET_LEFT Then GoTo LBrack
            If IsNumeric(Left(sEval, 1)) = False Then GoTo HaveFunc
         Case BRACKET_LEFT
LBrack:
            'That's easy - when we find a bracket - we just 'Eval' the expression in the brackets
            Num1 = Eval(ExtractBrackets(sEval))
            GotNum1 = True
         Case Else
            'Here Must make some checks for Functions (like when it's SIN(expr))
HaveFunc:
            Func = ExtractFunction(sEval, FuncExpr)
            Num1 = CalcFunction(Func, FuncExpr)
            GotNum1 = True
      End Select
   End If
   'Now Do the Calculation
   If Not GotNum1 Then Num1 = ExtractNumber(sEval)
   If Len(sEval) <> 0 Then
      Op = Left(sEval, 1)
      sEval = Mid(sEval, 2)
      'Check if the second number is a bracketed expression
      If Left(sEval, 1) = BRACKET_LEFT Then
         Num2 = Eval(ExtractBrackets(sEval))
      Else
         If IsNumeric(Left(sEval, 1)) = False Then
            Func = ExtractFunction(sEval, FuncExpr)
            Num2 = CalcFunction(Func, FuncExpr)
         Else
            Num2 = ExtractNumber(sEval)
         End If
      End If
      Select Case Op
         Case POWER_SIGN
            On Error GoTo ErrCalcMember
            dResult = Num1 ^ Num2
         Case Else
            m_Error = ERR_WRONG_SIGN
      End Select
   Else
      dResult = Num1
   End If
   If Len(sEval) <> 0 Then m_Error = ERR_WRONG_SYNTAX
   CalcMember = IIf(HaveMinus, -dResult, dResult)
   Exit Function
ErrCalcMember:
   m_Error = ERR_WRONG_FUNCTION
End Function

'***********************************************************
'This is nearly an equivalent of VAL,
'only here we may know if there was an error
'and it also modifies the string by removing the "Extracted" number

'TODO: It doesn't support the "2.34E+2" notation
Private Function ExtractNumber(ByRef EvalExpr$) As Double
   Dim HavePoint As Boolean, I As Integer, NewNum As String
   Dim TempChar As String, TempSign As String, HaveMinus As Boolean
   Dim sEval As String
   'Determine whether there is a sign in front of the string
   TempSign = Left(EvalExpr, 1)
   If TempSign = POINT_SIGN Then
      sEval = "0" & EvalExpr
   Else
      If Not IsNumeric(TempSign) Then
         sEval = Mid(EvalExpr, 2)
         HaveMinus = (TempSign = MINUS_SIGN)
      Else: sEval = EvalExpr
      End If
   End If

   For I = 1 To Len(sEval)
      TempChar = Mid(sEval, I, 1)
      If IsNumeric(TempChar) Then
         NewNum = NewNum & TempChar
      Else
         If TempChar = POINT_SIGN Then
            If HavePoint Then
               'We have already a point, that's an error
               m_Error = ERR_DBL_POINT
               Exit For
            Else
               HavePoint = True
               NewNum = NewNum + "."   'We shall use val in the end
            End If
         Else
            Exit For
         End If
      End If
   Next
   If NewNum = "" Then
      m_Error = ERR_WRONG_SYNTAX
   Else    'Cut out the number from the string
      EvalExpr = Mid(sEval, Len(NewNum) + 1)
   End If
   ExtractNumber = IIf(HaveMinus, -Val(NewNum), Val(NewNum))
End Function

'***********************************************************
'This is a Helper-func to SplitToMonomials
'it returns the position in a string of a Sign(1 or 2)
'it doesn't return the signs that are in brackets and the sign on the 1st place
Private Function GetSplitPos(ByVal EvalStr$, ByVal Sign1$, ByVal Sign2$, Optional StartPos As Integer = 1)
   Dim I%, InBracket%, TempChar$

   For I = StartPos To Len(EvalStr$)
      TempChar = Mid(EvalStr, I, 1)
      Select Case TempChar
         Case Sign1, Sign2
            If InBracket = 0 And I > 1 Then
               GetSplitPos = I
               Exit Function
            End If
         Case BRACKET_LEFT
            InBracket = InBracket + 1
         Case BRACKET_RIGHT
            InBracket = InBracket - 1
            If InBracket < 0 Then
               m_Error = ERR_WRONG_BRACKETS
               Exit Function
            End If
      End Select
   Next
End Function

'Gets a String, beginning with a Left Bracket and
'returns the expression in this bracket
'deletes this expression(with both brackets) from the string
Private Function ExtractBrackets(ByRef EvalExpr As String) As String
   Dim InBracket%, I&, TempChar$, RetStr$
   'We Suppose that the first sign in the string is BRACKET_LEFT
   InBracket = 1
   For I = 2 To Len(EvalExpr)
      TempChar = Mid(EvalExpr, I, 1)
      Select Case TempChar
         Case BRACKET_LEFT
            InBracket = InBracket + 1
         Case BRACKET_RIGHT
            InBracket = InBracket - 1
      End Select
      If InBracket = 0 Then
         RetStr = Mid(EvalExpr, 2, I - 2)
         EvalExpr = Mid(EvalExpr, I + 1)
         ExtractBrackets = RetStr
         Exit Function
      End If
   Next
   m_Error = ERR_WRONG_BRACKETS
End Function

'Process the expression "FUNC(expr)"
'Returns "FUNC"
Private Function ExtractFunction(ByRef EvalExpr As String, ByRef FuncExpr As String)
   Dim FuncID As String, I&
   I = InStr(EvalExpr, BRACKET_LEFT)
   If I = 0 Then
      m_Error = ERR_WRONG_SYNTAX
      Exit Function
   Else
      ExtractFunction = Left(EvalExpr, I - 1)
      EvalExpr = Mid(EvalExpr, I)
      FuncExpr = ExtractBrackets(EvalExpr)
   End If
End Function

'You give it a function name and an expression in the brackets after it
'as 2 separate strings, and it calculates
'ADD ANY of the Functions you like
'(E.G. it's interesting to add some 'acting' functions, like, say, MsgBox :)
'Then there are only several steps towards your own Script-Language
Private Function CalcFunction(ByVal FunctionID As String, ByVal FuncExpr As String) As Double
   On Error GoTo ErrCalc
   If m_Error <> ERR_NONE Then Exit Function
   Dim Arg As Double
   Arg = Eval(FuncExpr)
   Select Case FunctionID
      Case "ABS"
         CalcFunction = Abs(Arg)
      Case "ATN"
         CalcFunction = Atn(Arg)
      Case "COS"
         CalcFunction = Cos(Arg)
      Case "EXP"
         CalcFunction = Exp(Arg)
      Case "FIX"
         CalcFunction = Fix(Arg)
      Case "INT"
         CalcFunction = Int(Arg)
      Case "LOG"
         CalcFunction = Log(Arg)
      Case "RND"
         CalcFunction = Rnd(Arg)
      Case "SGN"
         CalcFunction = Sgn(Arg)
      Case "SIN"
         CalcFunction = Sin(Arg)
      Case "SQR"
         CalcFunction = Sqr(Arg)
      Case "TAN"
         CalcFunction = Tan(Arg)
         'Derived
      Case "SEC"
         CalcFunction = 1 / Cos(Arg)
      Case "COSEC"
         CalcFunction = 1 / Sin(Arg)
      Case "COTAN"
         CalcFunction = 1 / Tan(Arg)
      Case "ARCSIN"
         CalcFunction = Atn(Arg / Sqr(-Arg * Arg + 1))
      Case "ARCCOS"
         CalcFunction = Atn(-Arg / Sqr(-Arg * Arg + 1)) + 2 * Atn(1)
      Case "ARCSEC"
         CalcFunction = Atn(Arg / Sqr(Arg * Arg - 1)) + Sgn(Arg - 1) * (2 * Atn(1))
      Case "ARCCOSEC"
         CalcFunction = Atn(Arg / Sqr(Arg * Arg - 1)) + (Sgn(Arg) - 1) * (2 * Atn(1))
      Case "ARCCOTAN"
         CalcFunction = Atn(Arg) + 2 * Atn(1)
      Case "HSIN"
         CalcFunction = (Exp(Arg) - Exp(-Arg)) / 2
      Case "HCOS"
         CalcFunction = (Exp(Arg) + Exp(-Arg)) / 2
      Case "HTAN"
         CalcFunction = (Exp(Arg) - Exp(-Arg)) / (Exp(Arg) + Exp(-Arg))
      Case "HSEC"
         CalcFunction = 2 / (Exp(Arg) + Exp(-Arg))
      Case "HCOSEC"
         CalcFunction = 2 / (Exp(Arg) - Exp(-Arg))
      Case "HCOTAN"
         CalcFunction = (Exp(Arg) + Exp(-Arg)) / (Exp(Arg) - Exp(-Arg))
      Case "HARCSIN"
         CalcFunction = Log(Arg + Sqr(Arg * Arg + 1))
      Case "HARCCOS"
         CalcFunction = Log(Arg + Sqr(Arg * Arg - 1))
      Case "HARCTAN"
         CalcFunction = Log((1 + Arg) / (1 - Arg)) / 2
      Case "HARCSEC"
         CalcFunction = Log((Sqr(-Arg * Arg + 1) + 1) / Arg)
      Case "HARCCOSEC"
         CalcFunction = Log((Sgn(Arg) * Sqr(Arg * Arg + 1) + 1) / Arg)
      Case "HARCCOTAN"
         CalcFunction = Log((Arg + 1) / (Arg - 1)) / 2
         'Not Math functions, but also useful
      Case "TIMER"
         CalcFunction = Timer
      Case "YEAR"
         CalcFunction = Year(Now)
      Case "MONTH"
         CalcFunction = Month(Now)
      Case "DAY"
         CalcFunction = Day(Now)
      Case "WEEKDAY"
         CalcFunction = Weekday(Now)
      Case "HOUR"
         CalcFunction = Hour(Time)
      Case "MINUTE"
         CalcFunction = Minute(Time)
      Case "SECOND"
         CalcFunction = Second(Time)
         'These should be constants, but here you must use them as functions
         '(i.e. with an argument, no matter what)
      Case "PI"
         CalcFunction = 3.14159265358979
      Case "E"
         CalcFunction = 2.71828182845905
      Case "ZERO"
         CalcFunction = 0
      Case Else
         m_Error = ERR_WRONG_SYNTAX
   End Select
   Exit Function
ErrCalc:
   m_Error = ERR_WRONG_FUNCTION
End Function
0
HenryChanEAuthor Commented:
Thanks!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.