calexp.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 = "CalExp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'
'
'---------------------------------
'Class  :CalExp
'
'Program:zeng29
'Date   :2003/10/25
'Ver.   :1.0.0
'
'---------------------------------
'
'

Private Const cPi = 3.14159265358979
Private Const cE = 2.71828182845905

Public Function CalExpression(sExp1 As String, x As Double) As Variant
    Dim ReadPoint As Integer, i As Integer, j As Integer, sChar As String
    Dim sOpArray As Variant, iOpPower As Variant, sFunArray As Variant
    Dim DataStack() As Double, OpStack() As String
    Dim sCurOP As String, iIndex As Integer, iFlag As Integer, sPara As String
    Dim sFunName As String, vRet As Variant
    Dim dData1 As Variant, dData2 As Variant, sOp As String
    Dim sExp As String
    '初始化...
    ReDim DataStack(0)
    ReDim OpStack(0)
    sOpArray = Array("+", "-", "*", "/", "^", "%")
    iOpPower = Array(1, 1, 3, 3, 4, 2)
    sFunArray = Array("sin", "cos", "tan", "ctan", "asin", "acos", "atn", "actn", "abs", "ln", "pi", "e", "exp", "log")
    ReadPoint = 1
    Dim k As Integer
    Dim st0 As Variant
    Dim st1 As Variant
    Dim st2 As Variant
    Dim stz As String
    Dim sty As String
    Dim vret0, vret2
    Dim biao As Double
    biao = 0
     For k = 1 To Len(sExp1)
    st1 = Mid(sExp1, k, 1)
    If k = 1 Then
    st2 = Mid(sExp1, k + 1, 1)
    vret2 = GetIndex(sOpArray, st2)
    If st1 = "x" And (IsNumeric(st2) Or vret2 <> "Null") Then
     If x < 0 Then
    st1 = "(" + Str(x) + ")"
    Else
    st1 = Str(x)
    End If
    st1 = Trim(st1)
    sty = Right(sExp1, Len(sExp1) - k)
    
    sExp = st1 & sty
    biao = 1
    End If
    ElseIf k < Len(sExp1) Then
    st0 = Mid(sExp1, k - 1, 1)
    st2 = Mid(sExp1, k + 1, 1)
    vret0 = GetIndex(sOpArray, st0)
    vret2 = GetIndex(sOpArray, st2)
    If st1 = "x" And (IsNumeric(st2) Or vret2 <> "Null") And (IsNumeric(st0) Or vret0 <> "Null") Then
    If x < 0 Then
    st1 = "(" + Str(x) + ")"
    Else
    st1 = Str(x)
    End If
    st1 = Trim(st1)
    stz = Left(sExp1, k - 1)
    sty = Right(sExp1, Len(sExp1) - k)
    sExp = stz & st1 & sty
    biao = 1
    End If
    ElseIf k = Len(sExp1) Then
    st0 = Mid(sExp, k - 1, 1)
    vret0 = GetIndex(sOpArray, st0)
    If st1 = "x" And (IsNumeric(st0) Or vret0 <> "Null") Then
    If x < 0 Then
    st1 = "(" & Str(x) & ")"
    Else
    st1 = Str(x)
    End If
    st1 = Trim(st1)
    stz = Left(sExp1, k - 1)
    
    sExp = stz & st1
    biao = 1
    End If
    End If
    Next k
    
    If biao = 0 Then sExp = sExp1
    While ReadPoint <= Len(sExp)
        sChar = Mid(sExp, ReadPoint, 1)
        
        '运用递归处理"( )"...
        If sChar = "(" Then
            sPara = ""
            For i = ReadPoint To Len(sExp)
                sChar = Mid(sExp, i, 1)
                If sChar = "(" Then
                    iFlag = iFlag + 1
                ElseIf sChar = ")" Then
                    iFlag = iFlag - 1
                    If iFlag = 0 Then
                        vRet = CalExpression(sPara, x)
                        If IsNumeric(vRet) Then
                            PushToStc DataStack, vRet
                            ReadPoint = i + 1
                            Exit For
                        Else
                            CalExpression = vRet
                            Exit Function
                        End If
                    End If
                End If
                If iFlag <> 0 And i <> ReadPoint Then sPara = sPara & sChar
            Next i
            If iFlag <> 0 Then
                CalExpression = "错误的表达式:括号不成对!"
                Exit Function
            End If
        
        '读取数值...
        ElseIf IsNumeric(sChar) Or sChar = "." Then
            sPara = ""
            
            For i = ReadPoint To Len(sExp)
                sChar = Mid(sExp, i, 1)
                If IsNumeric(sChar) Or sChar = "." Then
                    sPara = sPara & sChar
                ElseIf IsNumeric(sPara) Then
                    PushToStc DataStack, sPara
                    ReadPoint = i
                    Exit For
                Else
                    CalExpression = "非法的表达式:" & sPara & sChar
                    Exit Function
                End If
            Next i
            If i > Len(sExp) And IsNumeric(sPara) Then PushToStc DataStack, sPara
            ReadPoint = i
        ElseIf (ReadPoint = 1 And (sChar = "+" Or sChar = "-")) Then
        sPara = "0"
        PushToStc DataStack, sPara
        PushToStc OpStack, sChar
        ReadPoint = 2
        Else
            vRet = GetIndex(sOpArray, sChar)
            
            '读取操作符...
            If vRet <> "Null" Then
ReCheck:
                If PopFromStc(OpStack, False) = "Null" Then
                    PushToStc OpStack, sChar
                Else
                    If iOpPower(vRet) > iOpPower(GetIndex(sOpArray, PopFromStc(OpStack, False))) Then
                        PushToStc OpStack, sChar
                    Else
                        dData2 = PopFromStc(DataStack)
                        dData1 = PopFromStc(DataStack)
                        sOp = PopFromStc(OpStack)
                        PushToStc DataStack, ProCal(dData1, dData2, sOp)
                        GoTo ReCheck
                    End If
                End If
            Else
            
                '读取函数...
                vRet = Asc(LCase(sChar))
                If vRet >= Asc("a") And vRet <= Asc("z") Then
                    sFunName = ""
                    For i = ReadPoint To Len(sExp)
                        sChar = Mid(sExp, i, 1)
                        vRet = Asc(LCase(sChar))
                        If vRet >= Asc("a") And vRet <= Asc("z") Then
                            sFunName = sFunName & sChar
                        ElseIf sChar = "(" Then
                            vRet = GetIndex(sFunArray, sFunName)
                            If vRet = "Null" Then
                                CalExpression = "不知道的函数:" & sFunName
                                Exit Function
                            End If
                            sPara = ""
                            iFlag = 0
                            For j = i To Len(sExp)
                                sChar = Mid(sExp, j, 1)
                                If sChar = "(" Then
                                    iFlag = iFlag + 1
                                ElseIf sChar = ")" Then
                                    iFlag = iFlag - 1
                                    If iFlag = 0 Then
                                        vRet = CallFun(sFunName, sPara, x)
                                        sFunName = ""
                                        If IsNumeric(vRet) Then
                                            PushToStc DataStack, vRet
                                            ReadPoint = j + 1
                                            GoTo ReadNext
                                        Else
                                            CalExpression = vRet
                                            Exit Function
                                        End If
                                    End If
                                End If
                                If iFlag <> 0 And (j <> i) Then sPara = sPara & sChar
                            Next j
                            If iFlag <> 0 Then
                                CalExpression = "错误的表达式:括号不成对!"
                                Exit Function
                            End If
                        End If
                        If i = Len(sExp) And sFunName <> "" Then
                            CalExpression = "函数的用法:函数名([参数])"
                            Exit Function
                        End If
                    Next i
                Else
                    CalExpression = "错误的表达式:不知道的操作符:" & sChar
                    Exit Function
                End If
            End If
            ReadPoint = ReadPoint + 1
        End If
ReadNext:
    Wend
    
    '运算最终结果...
    If UBound(DataStack) = 1 Then
        CalExpression = PopFromStc(DataStack)
    Else
        Do
            dData2 = PopFromStc(DataStack)
            dData1 = PopFromStc(DataStack)
            sOp = PopFromStc(OpStack)
            If IsNumeric(dData1) And IsNumeric(dData2) And sOp <> "Null" Then
                PushToStc DataStack, ProCal(dData1, dData2, sOp)
            Else
                CalExpression = "非法的表达式!"
                Exit Function
            End If
        Loop Until PopFromStc(OpStack, False) = "Null"
        CalExpression = PopFromStc(DataStack)
    End If
End Function

Public Function PopFromStc(ByRef Stack As Variant, Optional bDel As Boolean = True) As Variant
    If UBound(Stack) > 0 Then
        PopFromStc = Stack(UBound(Stack))
        If bDel Then
            ReDim Preserve Stack(UBound(Stack) - 1)
            Debug.Print PopFromStc & "↑"
        End If
    Else
        PopFromStc = "Null"
    End If
End Function

Public Function PushToStc(ByRef Stack As Variant, Element As Variant)
    ReDim Preserve Stack(UBound(Stack) + 1)
    Stack(UBound(Stack)) = Element
    Debug.Print Element & "↓"
End Function

Public Function GetIndex(vArray As Variant, vElement As Variant) As Variant
    Dim i As Integer
    For i = 0 To UBound(vArray)
        If vArray(i) = vElement Then
            GetIndex = i
            Exit Function
        End If
    Next i
    GetIndex = "Null"
End Function

Private Function ProCal(dData1 As Variant, dData2 As Variant, sOp As String) As Double
    Select Case sOp
        Case "+"
            ProCal = dData1 + dData2
        Case "-"
            ProCal = dData1 - dData2
        Case "*"
            ProCal = dData1 * dData2
        Case "/"
            ProCal = dData1 / dData2
        Case "^"
            ProCal = dData1 ^ dData2
        Case "%"
            ProCal = dData1 Mod dData2
    End Select
    Debug.Print dData1 & sOp & dData2 & "=" & ProCal
End Function

Private Function CallFun(sName As String, sPara As String, x As Double) As Variant
    Dim vRet As Variant, Temp As String
    
    Select Case sName
        Case "sin"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Sin(vRet)
            Else
                CallFun = vRet
            End If
        Case "cos"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Cos(vRet)
            Else
                CallFun = vRet
            End If
        Case "tan"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Tan(vRet)
            Else
                CallFun = vRet
            End If
        Case "ctan"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = 1 / Tan(vRet)
                
            Else
                CallFun = vRet
            End If
        Case "asin"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Atn(vRet / Sqr(-vRet * vRet + 1))
            Else
                CallFun = vRet
            End If
        Case "acos"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Atn(-vRet / Sqr(-vRet * vRet + 1)) + 2 * Atn(1)
            Else
                CallFun = vRet
            End If
        Case "atn"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Atn(vRet)
            Else
                CallFun = vRet
            End If
        Case "atn"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Atn(vRet) + 2 * Atn(1)
                
            Else
                CallFun = vRet
            End If
        Case "abs"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Abs(vRet)
            Else
                CallFun = vRet
            End If
        Case "ln"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Log(vRet)
            Else
                CallFun = vRet
            End If
        Case "log"
            vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Log(vRet) / Log(10)
            Else
                CallFun = vRet
            End If
        Case "pi"
            If sPara = "" Then
                CallFun = cPi
            Else
                CallFun = "pi()不带任何参数."
            End If
        Case "e"
            If sPara = "" Then
                CallFun = cE
            Else
                CallFun = "e()不带任何参数."
            End If
        Case "exp"
        vRet = CalExpression(sPara, x)
            If IsNumeric(vRet) Then
                CallFun = Exp(vRet)
            Else
                CallFun = vRet
            End If
    End Select
End Function

Public Property Get Pi() As Variant
    Pi = cPi
End Property

Public Property Get E() As Variant
    E = cE
End Property