cexpression.cls

運動會或各式活動秩序冊製作及檢錄表製作管理系統

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CExpression"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'--------------------------------------------------------------
'  A class for compiling and evaluating expressions
'  Author:  This code was originally obtained from VBPJ Journal
'           from an article written by Fransisco Balena
'           It was adapted and modified by the author to include
'           additional functions, and improved handling of invalid
'           calculations.
'  Kevin Matney
'  Date:        March 18, 1998
'Further improved by R. C. SHARMA [e-mail]
' Date September, 2001
'--------------------------------------------------------------

#Const SupportStrings = -1

'Option Explicit

Public Enum expErrorCode
    expOK = 0
    expSyntaxError
    expUnknownFunction
    expUnknownOperator
    expWrongNumberOfArguments
    expInvalidInputforFunction
End Enum

Private Enum expOpcodes
    opUnknown               ' used for errors
    opValue                 ' a constant or a variable
    opStart                 ' special opcodes (operands)
    opOpenBracket
    opMinus                 ' unary opcodes
    opNot
    
    opEnd                   ' special opcodes (operators)
    opComma                 ' DO NOT alter this order!
    opCloseBracket
    
    opFirst_BinaryOperator  ' binary opcodes (symbols)
    opPower = opFirst_BinaryOperator
    opMul
    opDiv                   ' IMPORTANT: these opcodes must be in a
    opIntDiv                ' sequence so that no opcode is a prefix
    opAdd                   ' for another opcode that follows it
    opSub                   ' (e.g. "<>" and "<=" must come before "<"
    opEq                    '  and ">=" must come before ">"
    opNe
    opLe
    opLt
    opGe
    opGt
    opMod                   ' binary opcodes (alphabetic)
    opAnd
    opOr
    opXor
#If SupportStrings Then
    opAppend
#End If

    opFirst_Function        ' opcode of first function
    opPi = opFirst_Function ' zero-argument functions
    opdeg
    oprad
    opAbs                   ' one-argument functions
    opInt
    opFix
    opSgn
    opSqr
    opLog
    opLn
    opExp
    opSin
    opAsin
    opCos
    opAcos
    opTan
    opAtn
    opAtan
    opSec
    opCosec
    opCotan  'add new functions here
    opSin_D
    opCos_D
    opTan_D
    opGAMMA
    opSINH
    opcosh
    opTANH
    opasinh
    opacosh
    opPow
    opMin                   ' two-argument functions
    opMax
    opIIf                   ' three-argument functions
    
#If SupportStrings Then
    opLen                   ' one-argument string functions
    opAsc
    opSpace
    opString                ' two-argument string functions
    opLeft
    opRight
    opMid                   ' three-argument string functions
    opInstr
#End If
    
    opDummy
    opLast_Opcode = opDummy - 1 ' last opcode used
End Enum

' max number of pending operators
Const STACK_SIZE = 30
' max number of items in the expression
Const MAX_ITEMS = 200

' the Default value, returned if a runtime occurs
Public DefaultValue As Variant

' if True (default), runtime errors are raised using the Err.Raise VBA method
' if False, errors are notified to the calling program only through
' the Error* properties
Public RaiseErrors As Boolean

' if True (default), variables are created as needed
' if False, an error occurs if a variable is not declared in advance
Public AutoCreateVariables As Boolean

' member variables
Private m_Expression As String
Private m_ErrorCode As expErrorCode
Private m_ErrorDescription As String
Private m_ErrorPos As Long

' the collection of variables
Private m_Variables As Collection

' the collection of roots
Private m_Roots As Collection

' these arrays hold information on all operands and functions
Dim opNames(opLast_Opcode) As String
Dim opPriority(opLast_Opcode) As Byte
Dim opNumArgs(opLast_Opcode) As Integer

' this holds the expression in compiled form
Dim compItems As Long
Dim compValues() As Variant
Dim compOpcodes() As Integer

' the expression to be evaluated

Property Get Expression() As String
    Expression = m_Expression
End Property

Property Let Expression(ByVal newvalue As String)
    m_Expression = newvalue
    ' compile the expression
    CompileExpression
End Property

' information on the current error code

Property Get ErrorCode() As expErrorCode
    ErrorCode = m_ErrorCode
End Property

Property Get ErrorDescription() As String
    ErrorDescription = m_ErrorDescription
End Property

Property Get ErrorPos() As Long
    ErrorPos = m_ErrorPos
End Property

' clear the error code

Sub ClearError()
    m_ErrorCode = expOK
    m_ErrorDescription = ""
    m_ErrorPos = 0
End Sub

' access to the variables

Function Variable(varName As Variant, Optional createIfNeeded As Boolean) As CVariable
    On Error Resume Next
    If IsNumeric(varName) Then
        Set Variable = m_Variables(varName)
    Else
        Set Variable = m_Variables(UCase$(varName))
        If Err > 0 And createIfNeeded Then
            Err = 0
            ' if it doesn't exist, create it if requested
            Dim newVar As New CVariable
            newVar.Name = varName
            ' add to the collection of variables
            AddVariable newVar
            Set Variable = newVar
        End If
    End If
End Function

Function AddVariable(newVar As CVariable) As Long
    ' add a new variable to the collection of variables
    ' recognized by this function, returns its index in the collection
    Dim ucaseName As String
    Dim Index As Integer
    
    On Error Resume Next

    ucaseName = UCase$(newVar.Name)
    
    ' add to the collection of variables
    ' this collection is always sorted on variable name
    m_Variables.Remove ucaseName
    Err = 0
    
    For Index = 1 To m_Variables.Count
        If UCase$(m_Variables(Index).Name) > ucaseName Then
            m_Variables.Add newVar, ucaseName, Index
            AddVariable = Index
            Exit Function
        End If
    Next
            
    ' add to the end of the collection
    m_Variables.Add newVar, ucaseName
    AddVariable = m_Variables.Count
            
End Function


Function VariablesCount() As Long
    VariablesCount = m_Variables.Count
End Function





' compile the expression (private)

Private Sub CompileExpression()
    Dim expr As String
    Dim Index As Long
    Dim sp As Integer
    Dim opSp As Integer
    Dim argSp As Integer
    Dim waitForOperator As Boolean
    Dim temp As Variant
    Dim opcode As Integer
    Dim newVar As CVariable
    
    ' reset the compiled expression and the roots
    compItems = 0
    ReDim compOpcodes(MAX_ITEMS) As Integer
    ReDim compValues(MAX_ITEMS) As Variant
    Set m_Roots = New Collection
    
    ' these are the temporary stacks used for parsing
    Dim opStack(STACK_SIZE) As Integer
    Dim argStack(STACK_SIZE) As Integer
    
    ' reset error codes
    m_ErrorCode = expOK
    m_ErrorDescription = ""

    ' add a trailing char to avoid errors and signal the expression end
    expr = m_Expression + opNames(opEnd)
    ' start with the highest priority
    opcode = opStart
    GoSub CompileExprPushOpcode
    Index = 1

    ' main compilation loop

    Do
        SkipBlanks expr, Index
        m_ErrorPos = Index
    
        If waitForOperator = False Then
    
            Select Case Mid$(expr, Index, 1)
            Case "0" To "9", "."
                ' found a numeric constant
                temp = GetNumber(expr, Index)
                If opStack(opSp) = opMinus Then
                    ' if there is an unary minus on the operator stack
                    ' this is a negative number
                    temp = -temp
                    opSp = opSp - 1
                End If
                AppendToCompiled opValue, temp
                sp = sp + 1
                waitForOperator = True
    
#If SupportStrings Then
            Case """", "'"
                ' a string constant
                temp = GetString(expr, Index)
                If m_ErrorCode = expSyntaxError Then GoTo CompileExprSyntaxError
                AppendToCompiled opValue, temp
                sp = sp + 1
                waitForOperator = True
#End If
            Case "+"
                ' unary plus - it is simply skipped over
                Index = Index + 1
    
            Case "-"
                ' unary minus
                opcode = opMinus
                GoSub CompileExprPushOpcode
                Index = Index + 1
    
            Case "("
                opcode = opOpenBracket
                GoSub CompileExprPushOpcode
                Index = Index + 1
    
            Case "A" To "Z", "a" To "z"
                ' this can be the NOT operator, a function name or a variable name
                temp = GetName(expr, Index)
                opcode = FunctionOpcode(UCase$(temp))
                
                If opcode = opNot Then
                    GoSub CompileExprPushOpcode
                ElseIf opcode <> opUnknown Then
                    ' we have found the name of a function
                    If opNumArgs(opcode) = 0 Then
                        ' zero-arg function are very like variables
                        AppendToCompiled opcode
                        sp = sp + 1
                        waitForOperator = True
                        ' zero-arg function may be followed by empty brackets
                        If Mid$(expr, Index, 2) = "()" Then
                            Index = Index + 2
                        End If
                    ElseIf Mid$(expr, Index, 1) = "(" Then
                        ' push the function opcode onto the stack
                        GoSub CompileExprPushOpcode
                        ' push the open bracket onto the stack ...
                        opcode = opOpenBracket
                        GoSub CompileExprPushOpcode
                        Index = Index + 1
                        ' ... but discard the new item added to argStack
                        argSp = argSp - 1
                    Else
                        ' all other functions must be followed by "("
                        m_ErrorDescription = ": missing brackets"
                        GoTo CompileExprSyntaxError
                    End If
                Else
                    ' it must be the name of a variable
                    Set newVar = Variable(temp, AutoCreateVariables)
                    If newVar Is Nothing Then
                        m_ErrorDescription = temp
                        GoTo CompileExprUnknownFunction
                    End If
                    AppendToCompiled opValue, newVar
                    sp = sp + 1
                    waitForOperator = True
                End If
                            
            Case Else
                ' any other character is a syntax error
                If Mid$(expr, Index, 1) = opNames(opEnd) Then
                    m_ErrorDescription = ": unexpected end of expression"
                Else
                    m_ErrorDescription = ": unknown symbol"
                End If
                GoTo CompileExprSyntaxError
    
            End Select