evaluator.cls

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

            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