evaluator.cls

饮羽公路测设（glcs） 由20多个公路测量、设计、试验和施工组织设计等小软件组成。如《中桩大地坐标》可以计算不等长缓和曲线的中桩和边桩的大地坐标；《缓和曲线反算》可以根据切线长、外距长或缓和曲线长求

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Evaluator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

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:  frmjsq.Text2 = "错误的分隔符"
                Case ERR_WRONG_BRACKETS: frmjsq.Text2 = "错误的括号"
                Case ERR_WRONG_SIGN: frmjsq.Text2 = "错误的符号"
                Case ERR_WRONG_SYNTAX: frmjsq.Text2 = "错误的表达式"
            End Select
        Else
            frmjsq.Text2 = Trim(Str(Res))
        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)