VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  ataBindingBehavior = 0  'vbNone
  ataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Expression"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const MyName As String = "ExpressionClass"

'Класс для вычисления выражений в строковой форме
'(c) Гергерт Сергей, 2003

'Магадан, 04.07.2003 01:10
'Всё, иду спать...

Private Const Plus As String = "+"
Private Const Minus As String = "-"

Private Const Mult As String = "*"
Private Const Div As String = "/"
Private Const DivInt As String = "\"

Private Const Power As String = "^"

Private Const LeftPar As String = ""
Private Const RightPar As String = ""

Public Enum ExprErrors
  exprNoError
  exprErrorParentheses
  exprErrorInvalidExpression
  exprErrorUnknownFunction
End Enum

Public Function Value(ByVal E As String) As Double
Attribute Value.VB_UserMemId = 0
  Dim i As Long
  Dim tmpLng As Long, tmpStr As String
  
  E = LCase$(Replace(E, " ", vbNullString))
  E = Replace(E, RightPar + LeftPar, RightPar + Mult + LeftPar)
  
  'Сначал убедимся, что скобки расставлены верно.
  'Идём слева направо. Открывающая скобка - плюс 1,
  'закрывающая - минус 1. Всё время должно быть >=0, а в конце =0
  
  For i = 1 To Len(E)
    tmpStr = Mid$(E, i, 1)
    If tmpStr = LeftPar Then
      tmpLng = tmpLng + 1
    ElseIf tmpStr = RightPar Then
      tmpLng = tmpLng - 1
    End If
    If tmpLng < 0 Then Err.Raise exprErrorParentheses, MyName, "Parentheses do not match"
  Next
  If tmpLng Then Err.Raise exprErrorParentheses, MyName, "Parentheses do not match"
  
  Value = CalcSummand(E)
End Function

Private Function CalcSummand(S As String) As Double
  Dim i As Long, minPrior As Byte, minPriorPos As Long
  Dim NestingLevel As Long, tmpStr As String
  
  'Не пустая ли строка?
  If Len(S) = 0 Then Exit Function 'выходим с нулём
  
  'Проверяем, не являются ли самые внешние скобки лишними
  Do While LISP(S)
  Loop
  
  'Ищем первый оператор с минимальным приоритетом на текущем уровне вложенности
  minPrior = 2
  For i = 1 To Len(S)
    Select Case Mid$(S, i, 1)
    Case LeftPar
      NestingLevel = NestingLevel + 1
    Case RightPar
      NestingLevel = NestingLevel - 1
    Case Plus, Minus
      If NestingLevel = 0 Then
        minPrior = 0
        minPriorPos = i
        Exit For
      End If
    Case Mult, Div, DivInt
      If NestingLevel = 0 Then
        If minPrior = 2 Then
          minPrior = 1
          minPriorPos = i
        Else
          If minPriorPos = 0 Then minPriorPos = i
        End If
      End If
    Case Power
      If NestingLevel = 0 Then
        If minPrior = 2 And minPriorPos = 0 Then minPriorPos = i
      End If
    End Select
  Next
  
  If minPriorPos = 0 Then
    'Сие означает, что операторов на текущем уровне вложенности нет.
    'Это, в свою очередь, означает, что либо операнд есть число,
    'либо он есть функция.
    CalcSummand = IsFunction(S)
    If CalcSummand >= 0 Then
      Exit Function 'операнд был числом, и он вычислен
    Else
      'Операнд был функцией. Других вариантов нет, т.к. ошибка генерится в IsFunction
      'Переменная minPriorPos нам больше не нужна по прямому назначению.
      'Поэтому заюзаем её для других целей. Просто очень капризная рекурсия
      'в VB, стэк экономим-с...
      minPriorPos = InStr(S, LeftPar)
      tmpStr = Left$(S, minPriorPos - 1)
      'Вот почему нельзя вызывать CallByName от модуля?
      'Сколько бы гемора исчезло...
      Select Case tmpStr
      Case "abs"
        CalcSummand = Abs(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "atn"
        CalcSummand = Atn(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "cos"
        CalcSummand = Cos(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "exp"
        CalcSummand = Exp(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "log"
        CalcSummand = Log(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "sgn"
        CalcSummand = Sgn(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "sin"
        CalcSummand = Sin(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "sqr"
        CalcSummand = Sqr(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "tan"
        CalcSummand = Tan(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case Else
        Err.Raise exprErrorUnknownFunction, MyName, "Unknown function " + UCase$(tmpStr) + " detected"
      End Select
    End If
  Else
    'Нашли искомый оператор. Рекурсия...
    If minPriorPos = 1 Then 'выражение типа -expr
      tmpStr = Left$(S, 1)
      If tmpStr = Plus Or tmpStr = Minus Then
        CalcSummand = IIf(tmpStr = Minus, -1, 1) * CalcSummand(Mid$(S, 2))
      Else
        Err.Raise exprErrorInvalidExpression, MyName, "Expression is invalid"
      End If
    Else                    'обычное a +-*/\^ b
      Select Case Mid$(S, minPriorPos, 1)
      Case Plus
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) + CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Minus
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) - CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Mult
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) * CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Div
        'Ошибку деления на ноль VB сгенерит и без нас...
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) / CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case DivInt
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) \ CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Power
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) ^ CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Else
        'В принципе, этого возникать не должно никогда...
        Err.Raise exprErrorInvalidExpression, MyName, "Expression is invalid"
      End Select
    End If
  End If
End Function

Private Function LISP(ByRef S As String) As Boolean
  Dim i As Long, tmp As Long
  
  'LISP = Lots of Idiot Silly Parentheses!
  'Фанаты языка LISP в шоке и готовят помидоры...
  
  'Если уровень скобок по ходу выражения опустится до нуля,
  'и это будет не конец выражения, то начальные и конечные
  'скобки нужны, поскольку принадлежат разным группам.
  'Иначе их можно удалить.
  
  If Left$(S, 1) = LeftPar And Right$(S, 1) = RightPar Then
    For i = 1 To Len(S)
      If Mid$(S, i, 1) = LeftPar Then
        tmp = tmp + 1
      ElseIf Mid$(S, i, 1) = RightPar Then
        tmp = tmp - 1
        If tmp = 0 And i <> Len(S) Then Exit Function
      End If
    Next
  Else
    Exit Function
  End If
  
  'Скобки нужно удалить
  S = Mid$(S, 2, Len(S) - 2)
  LISP = True
End Function

Private Function IsFunction(F As String) As Double
  'Функция - несколько подряд идущих букв и выражение в скобках.
  'И больше ничего! Выражение типа "функция + функция" сюда попадать не должно,
  'по логике основной части программы
  Dim i As Long
  
  'правильность скобок гарантируется вызывающим кодом, поэтому достаточно
  'проверить наличие одной, а не обоих
  i = InStr(F, LeftPar)
  If i = 0 Then
    'Явно не функция. Может, число?
    For i = 1 To Len(F)
      If InStr("0123456789.", Mid$(F, i, 1)) = 0 Then Exit For
    Next
    If i = Len(F) + 1 Then IsFunction = Val(F) Else Err.Raise exprErrorInvalidExpression, MyName, "Expression is invalid"
    'логика программы такова, что отрицательное число вычисляется
    'как (-)(expression), поэтому здесь всегда результат положительный,
    'и можно использовать отрицательные числа как флаги
    Exit Function
  End If
  
  'левая (а значит, и правая) скобки есть, и это не начальные ненужные скобки.
  'Слева от левой скобки должнно быть имя функции. Его правильность будет
  'анализировать вызывающий код
  IsFunction = -1 'Флаг, что функция
End Function