# 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
###### 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.

Commented:
' #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
'          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 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_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

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 & "("
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
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

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

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
j = j + 1
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
j = j + 1
EquPriority.Add p + PRI_MUL, , j
j = j + 1
EquPriority.Add p + PRI_PAR, , j
j = j + 1
s = ""
Else
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
EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
j = j + 1
s = ""
End If

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

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

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

Case "+":
If t <> EQ_NONE Then
If t <> EQ_CLOSE_PAREN Then
EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
j = j + 1
s = ""
End If
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
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
j = j + 1
t = EQ_NONE
Else ' we are a negation sign
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
EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
j = j + 1
s = ""
End If

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

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

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

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

j = j + 1
t = EQ_NONE

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

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
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

For j = 1 To maxPriority
For i = EquPriority.Count To 1 Step -1
If EquPriority(i) = j Then
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
Else
Temp(m) = Atn(X)
End If

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

Case "cos("
If Degrees Then
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
Else
Temp(m) = Sin(X)
End If

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

Case "tan("
If Degrees Then
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
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

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

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

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

Commented:
' #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 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_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

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

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
j = j + 1
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
j = j + 1
EquPriority.Add p + PRI_MUL, , j
j = j + 1
EquPriority.Add p + PRI_PAR, , j
j = j + 1
s = ""
Else
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
EquPriority.Add IIf(t = EQ_STRING, p + PRI_VAR, 0), , j
j = j + 1
s = ""
End If

EquPriority.Add p + PRI_MUL, , j
j = j + 1
t = EQ_NONE
isNeg = False

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

EquPriority.Add p + PRI_MUL, , j
j = j + 1
t = EQ_NONE
isNeg = False

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

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

If isNeg Then
j = j + 1
t = EQ_NONE
Else
EquPriority.Add p + PRI_NEG, , j
j = j + 1
t = EQ_NONE
End If

isNeg = False

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

EquPriority.Add p + PRI_EXP, , j
j = j + 1
t = EQ_NONE
isNeg = False

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

EquPriority.Add p + PRI_MOD, , j
j = j + 1
t = EQ_NONE
isNeg = False

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

j = j + 1
t = EQ_NONE
isNeg = False

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

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
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

For j = 1 To maxPriority
For i = EquPriority.Count To 1 Step -1
If EquPriority(i) = j Then
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

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
Else
Temp(m) = Atn(X)
End If

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

Case "cos("
If Degrees Then
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
Else
Temp(m) = Sin(X)
End If

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

Case "tan("
If Degrees Then
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
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

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

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
End Property

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

0
Commented:
' #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
' *
' *
' **********************************************************************
'_____________________________________________________
'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-
'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
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\$
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
Author 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.