clsexpression.cls

ERP管理系统源代码erp 管理系统源代码

                    Exit Do
                End If
            Loop
                    
            SymbolName = Mid(mExpression, mPosition, CurrPosition - mPosition)
            mPosition = CurrPosition
            SkipSpaces
        
            ' If there are openning parentheses, it's a
            ' function call
            CurrToken = GetToken
            If CurrToken = TOK_OPEN_PARENTHESES Then
                SkipLastToken
                ' Get the argument to the function.
                ' Multi-argument functions are very
                ' easy to implement here.
                ArgumentValue = ParseNumExp
                
                CurrToken = GetToken
                If CurrToken = TOK_CLOSE_PARENTHESES Then
                    SkipLastToken
                Else
                    Err.Raise PERR_CLOSING_PARENTHESES_EXPECTED, , "')' Expected"
                End If
            
                Value = CallBuiltinFunction(SymbolName, _
                    ArgumentValue)
                IsValue = True
            Else
                ' The symbol is supposed to be a constant
                ' name - check if it really exists
                If ConstExists(SymbolName) Then
                    Value = mConstants(SymbolName)
                    IsValue = True
                Else
                    Err.Raise PERR_CONST_DOES_NOT_EXIST, , _
                        "Constant name " & SymbolName & " does not exist"
                End If
            End If
        End If
    End If

    If Not IsValue Then
        ' We didn't recognize the value
        Err.Raise PERR_SYNTAX_ERROR, , GENERIC_SYNTAX_ERR_MSG
    End If

    ParseAtom = Value
    Exit Function
    
ParseAtom_ErrHandler:
    SetErrSource "ParseAtom"
    Err.Raise Err.Number
End Function

Private Function GetToken() As ParserTokens
    Dim CurrToken As ParserTokens
    Dim i As ParserTokens
    
    If mPosition > Len(mExpression) Then
        GetToken = TOK_UNKNOWN
        Exit Function
    End If
    
    CurrToken = TOK_UNKNOWN
    mLastTokenLength = 0
    
    ' Iterate all known tokens and check if they match
    For i = TOK_FIRST To TOK_LAST
        If Mid(mExpression, mPosition, Len(mTokenSymbols(i))) = mTokenSymbols(i) Then
            CurrToken = i
            
            ' Save the token length so we can skip over it
            ' easily later
            mLastTokenLength = Len(mTokenSymbols(i))
            Exit For
        End If
    Next
    
    GetToken = CurrToken
End Function

Private Sub SkipLastToken()
    ' Skip over the last token, plus any spaces after it
    mPosition = mPosition + mLastTokenLength
    SkipSpaces
End Sub

'''''''''''''''''''''''''''''''
'
' Constants handling functions
'
'''''''''''''''''''''''''''''''
' Unlike the Scripting.Dictionary class, the Collection
' class has no method to check whether a key exists.
' This is HIGHLY inconvenient, so let's wrap it in a
' function
Private Function ConstExists(ByVal Name As String) As Boolean
    Const ERR_KEY_NOT_FOUND = 5
    Dim DummyValue As Double

    On Error Resume Next
    DummyValue = mConstants(Name)
    
    If Err.Number = ERR_KEY_NOT_FOUND Then
        ConstExists = False
    Else
        ConstExists = True
    End If
End Function

Public Sub AddConstant(ByVal Name As String, ByVal Value As Double)
    Dim i As ParserTokens
    Dim TempName As String

    TempName = UCase(Trim(Name))
   
    ' Do all validity checks
    If Len(TempName) = 0 Then
        Err.Raise PERR_INVALID_CONST_NAME, , "Constant name cannot be null"
    End If

    If Not IsLetter(Left(TempName, 1)) Then
        Err.Raise PERR_INVALID_CONST_NAME, , "Constant name must begin with a letter"
    End If
            
    For i = 2 To Len(TempName)
        If Not IsValidSymbolCharacter(Mid(TempName, i, 1)) Then
            Err.Raise PERR_INVALID_CONST_NAME, , "Invalid constant name"
        End If
    Next
    
    If ConstExists(TempName) Then
        Err.Raise PERR_CONST_ALREADY_EXISTS, , "The constant already exists"
    End If
    
    If IsBuiltInFunction(TempName) Then
        Err.Raise PERR_RESERVED_WORD, , "The name is a reserved word"
    End If
    
    mConstants.Add Value, TempName
End Sub

Public Sub RemoveConstant(Optional ByVal Name As String = "")
    Dim TempName As String, i As Integer
    
    If Name <> "" Then
        TempName = UCase(Trim(Name))
        
        If ConstExists(TempName) Then
            mConstants.Remove TempName
        Else
            Err.Raise PERR_CONST_DOES_NOT_EXIST, , _
                "Constant name " & TempName & " does not exist"
        End If
    Else
        For i = mConstants.Count To 1 Step -1
            mConstants.Remove i
        Next i
    End If
End Sub


'''''''''''''''''''''''''''''''''
'
' 'Built-in function' functions...
'
'''''''''''''''''''''''''''''''''
' Check if a string name does stand for a supported built-in
' function - You may add as many as you like
Private Function IsBuiltInFunction(ByVal Name As String) As Boolean
    Dim TempName As String

    TempName = UCase(Trim(Name))
    If TempName = "SIN" Or _
       TempName = "COS" Or _
       TempName = "ABS" Then

        IsBuiltInFunction = True
    Else
        IsBuiltInFunction = False
    End If
End Function

' Execute the built-in function, and return its result
Private Function CallBuiltinFunction(ByVal Name As String, Argument As Double) As Double
    On Error GoTo CallBuiltinFunction_ErrHandler
    Const DEGREES_TO_RADIANS = PI / 180
    Dim TempName As String

    If Not IsBuiltInFunction(Name) Then
        Err.Raise PERR_FUNCTION_DOES_NOT_EXIST, , _
            "Function " & Name & " Does not exist"
    End If
    
    TempName = UCase(Trim(Name))

    Select Case TempName
    Case "SIN"
         ' VB Trigonometric functions work with radians, so
         ' we need to convert the argument to radians
         CallBuiltinFunction = Sin(Argument * DEGREES_TO_RADIANS)
    Case "COS"
         CallBuiltinFunction = Cos(Argument * DEGREES_TO_RADIANS)
    Case "ABS"
         CallBuiltinFunction = Abs(Argument)
    End Select

    Exit Function
CallBuiltinFunction_ErrHandler:
    SetErrSource "CallBuiltinFunction"
    Err.Raise Err.Number
End Function

'''''''''''''''''''
'
' Helper functions
'
'''''''''''''''''''
Private Sub SkipSpaces()
    ' Skip spaces/tabs in the expression
    Do While mPosition <= Len(mExpression) And _
             (Mid(mExpression, mPosition, 1) = " " Or _
              Mid(mExpression, mPosition, 1) = vbTab)
        mPosition = mPosition + 1
    Loop
End Sub

' Check if a character is an english letter
Private Function IsLetter(ByVal Character As String) As Boolean
    Dim CharAsciiCode As Long

    CharAsciiCode = Asc(UCase(Character))
    If (CharAsciiCode >= Asc("A") And _
        CharAsciiCode <= Asc("Z")) Then
        IsLetter = True
    Else
        IsLetter = False
    End If
End Function

' Check if a character is an english letter / a number /
' an underscore
Private Function IsValidSymbolCharacter(ByVal Character As String) As Boolean
    If IsLetter(Character) Or _
       IsNumeric(Character) Or _
       Character = "_" Then
            
        IsValidSymbolCharacter = True
    Else
        IsValidSymbolCharacter = False
    End If
End Function

'''''''''''''''''''''''''''
'
' Error handling functions
'
'''''''''''''''''''''''''''
' Why do we need the project name? Well, when an error is
' first raised, the err.Source property is set to the project
' name. The SetErrSource function needs to know whether the error
' caught was generated in the "host" function, or propagated
' from a lower-level function. Checking the Source property
' is a good way to test it.
Private Function GetProjectName() As String
    On Error Resume Next
    ' Quite a way to get the project name...
'    Err.Raise 1, , " "
'    GetProjectName = Err.Source
'    Err.Clear
End Function

Private Sub SetErrSource(ByVal Name As String)
    If Err.Source = mProjectName Then
        ' Error was "just raised", the supplied function name
        ' is the lowest function in the call stack
        Err.Source = Name
    Else
        ' The error was propagated from a lower-level function.
        ' Add "this" function name to the call stack
        Err.Source = Name & "->" & Err.Source
    End If
End Sub

' This property can tell the programmer where the
' parser raised an error - Note that the value returned
' may not be what you expected... Experiment with
' syntax errors
Public Property Get LastErrorPosition() As Long
    LastErrorPosition = mPosition
End Property

'''''''''''''''''''''''''''
'
' Initialization
'
'''''''''''''''''''''''''''
Private Sub Class_Initialize()
    ' Initilalize token symbols
    ReDim mTokenSymbols(TOK_FIRST To TOK_LAST)

    mTokenSymbols(TOK_ADD) = "+"
    mTokenSymbols(TOK_SUBTRACT) = "-"
    mTokenSymbols(TOK_MULTIPLY) = "*"
    mTokenSymbols(TOK_DIVIDE) = "/"
    mTokenSymbols(TOK_OPEN_PARENTHESES) = "("
    mTokenSymbols(TOK_CLOSE_PARENTHESES) = ")"

    ' Initilalize constants collection &
    ' add built-in constants
    Set mConstants = New Collection
    mConstants.Add PI, "PI"
    
    ' Get project name for proper error handling
    mProjectName = GetProjectName
End Sub