modcalculate.bas

表达式计算器,计算灵活,可计算函数,三角函数等,很好用哦.

Attribute VB_Name = "modCalculate"
Option Explicit

Private CurrentEntryIndex As Integer
Private ErrorMessage As String
Private Help As Boolean
Private InError As Boolean
Private InputString As String
Private OutputString As String
Private OutputValue As Double
Private Value As Double

Public PrevAnswer As Double
Public PrevEntry As String

Const Pi = 3.14159265358979
''''''''''''''''''''''''''''''''''''''
'      Mathematical Grammar Key      '
'          (Hierarchy Chart)         '
''''''''''''''''''''''''''''''''''''''
'                                    '
'  E ::=  T | T + E | T - E          '
'  T ::=  F | F * T | F / T          '
'  F ::=  Number | ( E )             '
'                                    '
''''''''''''''''''''''''''''''''''''''
'                                    '
'  Final Result:            E        '
'                           |        '
'                           T        '
'                          /|\       '
'                         F \ T      '
'                        /|\ \ \     '
'                       / E \ \ \    '
'                      / /|\ \ \ \   '
'                     / T | E \ \ F  '
'                     | | | | | | |  '
'                     | | | T | | |  '
'                     | | | | | | |  '
'                     | F | F | | |  '
'                     | | | | | | |  '
'  Base Equation:     | 1 + 2 ) * 3  '
'                                    '
''''''''''''''''''''''''''''''''''''''
'                                    '
'  Example:                          '
'                                    '
'  Final Result:            9        '
'                           |        '
'                           9        '
'                          /|\       '
'                         3 * 3      '
'                        /|\ \ \     '
'                       ( 3 ) * 3    '
'                      / /|\ \ \ \   '
'                     ( 1 + 2 ) * 3  '
'                     | | | | | | |  '
'                     ( 1 + 2 ) * 3  '
'                     | | | | | | |  '
'  Base Equation:     ( 1 + 2 ) * 3  '
'                                    '
''''''''''''''''''''''''''''''''''''''

Public Sub CalculateEntry()
'On Error GoTo ErrorHandler:
Dim Answer As String
Dim BinAnswer As String
Dim DecimalCheck As Long
Dim Remainder As String
Dim Tag As String

    'Set default values
    CurrentEntryIndex = 1
    Help = False
    InError = False
    InputString = frmCalcSolver.txtEntry.Text
    PrevEntry = frmCalcSolver.txtEntry.Text

    'Extract the first token
    ExtractToken

    'Evaluate the entire expression
    Answer = CStr(GetE)

    'Open Syntax help
    If Help Then
        frmCalcSolver.mnuHelpHelp_Click
        Exit Sub
    End If

    'If we "finished" the evaluation prematurely, an
    'error occured
    If Not InError And OutputString <> "EOS" Then
        TrapErrors 0
    End If

    'Set error message if error occurred
    If InError Then
        Answer = ">> " + ErrorMessage + vbNewLine + frmCalcSolver.txtAnswer.Text

    Else

        'Set previous answer
        PrevAnswer = Answer
        Tag = ""
        If frmCalcSolver.optBaseMode(1).Value = True Then

            'Convert to binary if necessary
            If CDbl(Answer) <= 32767 Then
                BinAnswer = ""
                DecimalCheck = InStr(1, CStr(Answer), ".")
                If DecimalCheck <> 0 Then
                    If CInt(Mid(CStr(Answer), DecimalCheck + 1, 1)) < 5 Then
                        Answer = CDbl(Left(Answer, DecimalCheck - 1))
                    Else
                        Answer = CDbl(Left(Answer, DecimalCheck - 1)) + 1
                    End If
                End If
                Do
                    Answer = Answer / 2
                    DecimalCheck = InStr(1, CStr(Answer), ".")
                    If DecimalCheck = 0 Then
                        Remainder = "0"
                    Else
                        Answer = CDbl(Left(Answer, DecimalCheck - 1))
                        Remainder = "1"
                    End If
                    BinAnswer = Remainder + BinAnswer
                Loop Until Answer < 1
                Answer = CDbl(BinAnswer)
                Tag = " (bin)"
            End If
        ElseIf frmCalcSolver.optBaseMode(2).Value = True Then

            'Convert to hexadecimal if necessary
            Answer = Hex(Answer)
            Tag = " (hex)"
        ElseIf frmCalcSolver.optBaseMode(3).Value = True Then

            'Convert to octadecimal if necessary
            Answer = Oct(Answer)
            Tag = " (oct)"
        End If
        Answer = ">> " + Answer + Tag + vbNewLine + frmCalcSolver.txtAnswer.Text
    End If

    'Display final answer
    frmCalcSolver.txtAnswer.Text = Answer

    Exit Sub

ErrorHandler:

    'Trap errors
    TrapErrors Err.Number

End Sub

Private Sub ExtractToken()
Dim Char As String
Dim i As Integer
Dim ValueString As String

    '********************
    '* SCANNING ROUTINE *
    '********************

    'Set default values
    OutputString = ""
    OutputValue = 0
    ValueString = ""

    'If at the end of string, return EOS
    If CurrentEntryIndex > Len(InputString) Then
        OutputString = "EOS"
        Exit Sub
    End If

    'Get character to be examined
    Char = Mid(InputString, CurrentEntryIndex, 1)

    'Space
    If Char = " " Then
        CurrentEntryIndex = CurrentEntryIndex + 1
        ExtractToken
        Exit Sub
    End If

    'Operator or parenthesis
    If Char = "+" Or Char = "-" Or Char = "*" Or Char = "/" Or Char = "^" Or Char = "(" Or Char = ")" Then
        CurrentEntryIndex = CurrentEntryIndex + 1

        'Set return value
        OutputString = Char
        Exit Sub
    End If

    'Number
    If (Char >= "0" And Char <= "9") Or Char = "." Then

        'Digits before decimal
        While Char >= "0" And Char <= "9"
            ValueString = ValueString + Char
            CurrentEntryIndex = CurrentEntryIndex + 1
            If CurrentEntryIndex <= Len(InputString) Then
                Char = Mid(InputString, CurrentEntryIndex, 1)
            Else
                Char = ""
            End If
        Wend

        'Decimal
        While Char = "."
            ValueString = ValueString + Char
            CurrentEntryIndex = CurrentEntryIndex + 1
            If CurrentEntryIndex <= Len(InputString) Then
                Char = Mid(InputString, CurrentEntryIndex, 1)
            Else
                Char = ""
            End If
        Wend

        'Digits after decimal
        While Char >= "0" And Char <= "9"
            ValueString = ValueString + Char
            CurrentEntryIndex = CurrentEntryIndex + 1
            If CurrentEntryIndex <= Len(InputString) Then
                Char = Mid(InputString, CurrentEntryIndex, 1)
            Else
                Char = ""
            End If
        Wend

        'Set return values
        OutputString = "Number"
        OutputValue = CDbl(ValueString)
        Exit Sub
    End If

    'Return text language identifiers
    If LCase(Char) >= "a" And LCase(Char) <= "z" Then
        While (LCase(Char) >= "a" And LCase(Char) <= "z")
            ValueString = ValueString + Char
            CurrentEntryIndex = CurrentEntryIndex + 1
            If CurrentEntryIndex <= Len(InputString) Then
                Char = Mid(InputString, CurrentEntryIndex, 1)
            Else
                Char = ""
            End If
        Wend

        'Set return value
        OutputString = LCase(ValueString)
        Exit Sub
    End If

End Sub

Private Function GetE()
On Error GoTo ErrorHandler

    '*****************************
    '* PARSING ROUTINE (Level 1) *
    '*****************************

    'Get the lower value (T)
    Value = GetT

    'Exit function on error or help call
    If InError Or Help Then
        Exit Function
    End If

    Select Case OutputString

        'Addition operator
        Case "+"
            ExtractToken
            GetE = Value + GetE()

        'Subraction operator
        Case "-"
            ExtractToken
            GetE = Value - GetE()

        'Everything else passes upwards
        Case Else
            GetE = Value
    End Select

    Exit Function

ErrorHandler:

    'Trap errors
    TrapErrors Err.Number

End Function

Private Function GetT()
On Error GoTo ErrorHandler
Dim Exponent As Double

    '*****************************
    '* PARSING ROUTINE (Level 2) *
    '*****************************

    'Get the lower value (F)
    Value = GetF

    'Exit function on error or help call
    If InError Or Help Then
        Exit Function
    End If

    Select Case OutputString

        'Multiplication operator
        Case "*"
            ExtractToken
            GetT = Value * GetT()

        'Division operator
        Case "/"
            ExtractToken
            GetT = Value / GetT()

        'Parenthesis
        Case "("
            GetT = Value * GetT()

        'Exponent
        Case "^"
            ExtractToken
            If OutputString = "(" Then
                Exponent = GetE
                If OutputString <> ")" Then
                    TrapErrors 0
                    Exit Function
                End If
                GetT = Value ^ Exponent
                Exit Function
            End If
            GetT = Value ^ OutputValue
            ExtractToken

        Case Else

            'Addition operator, subtraction operator,
            'EOS flag, or right parenthesis
            If OutputString = "+" Or OutputString = "-" Or OutputString = "EOS" Or OutputString = ")" Then
                GetT = Value

            'Everything else multiplies
            Else
                GetT = Value * GetF
                ExtractToken
            End If
    End Select

    Exit Function

ErrorHandler:

    'Trap errors
    TrapErrors Err.Number

End Function

Private Function GetF()
On Error GoTo ErrorHandler
Dim Base As Double
Dim Char As String
Dim NumDecimals As Long
Dim i As Integer
Dim Text As String

    '*****************************
    '* PARSING ROUTINE (Level 3) *
    '*****************************

    'Handle the low level calculations
    Select Case OutputString

        'Number
        Case "Number"
            GetF = OutputValue
            ExtractToken

        'Negative
        Case "-"
            ExtractToken
            Value = GetE
            GetF = (-Value)
            ExtractToken

        'Parenthesis
        Case "("
            ExtractToken
            Value = GetE
            If OutputString <> ")" And OutputString <> "EOS" Then
                TrapErrors 0
                Exit Function
            End If
            ExtractToken
            GetF = Value

        'Previous answer
        Case "ans"
            GetF = PrevAnswer
            ExtractToken

        'e
        Case "e"
            GetF = Exp(1)
            ExtractToken

        Case "help"
            Help = True

        'Logarithm (to a base)
        Case "log"