📄 cexpression.cls
字号:
Tos = stak(sp) Or Tos
sp = sp - 1
Case opXor
Tos = stak(sp) Xor Tos
sp = sp - 1
Case opPi
sp = sp + 1
stak(sp) = Tos
Tos = 3.14159265358979
Case oprad 'opdeg
sp = sp + 1
stak(sp) = Tos
Tos = Tos * 3.14159265358979 / 180
'Tos = Atn(1) / 45
Case opdeg 'opRad
sp = sp + 1
stak(sp) = Tos
Tos = Tos * 180 / 3.14159265358979 ' / 180
'Tos = 45 / Atn(1)
Case opAbs
Tos = Abs(Tos)
Case opInt
Tos = Int(Tos)
Case opFix
Tos = Fix(Tos)
Case opSgn
Tos = Sgn(Tos)
Case opSqr
Tos = Sqr(Tos)
Case opLn
If Tos > 0 Then
Tos = Log(Tos)
Else
Value = DefaultValue
m_ErrorCode = expInvalidInputforFunction
m_ErrorDescription = "Cannot take Natural Log of a negative number"
Error = m_ErrorCode
End If
Case opLog
If Tos > 0 Then
Tos = Log(Tos) / Log(10)
Else
Value = DefaultValue
m_ErrorCode = expInvalidInputforFunction
m_ErrorDescription = "Cannot take LOG of a negative number"
Error = m_ErrorCode
End If
Case opExp
Tos = Exp(Tos)
Case opSin
Tos = Sin(Tos)
Case opAsin
If Tos = -1 Or Tos = 1 Then
Tos = 2 * Atn(1) * Tos
ElseIf Tos > -1 And Tos < 1 Then
Tos = Atn(Tos / Sqr(-Tos * Tos + 1))
Else
Value = DefaultValue
m_ErrorCode = expInvalidInputforFunction
m_ErrorDescription = "Invalid Input for ASIN"
Error = m_ErrorCode
End If
Case opCos
Tos = Cos(Tos)
Case opAcos
If Tos = -1 Or Tos = 1 Then
Tos = 0
ElseIf Tos > -1 And Tos < 1 Then
Tos = Atn(-Tos / Sqr(-Tos * Tos + 1)) + 2 * Atn(1)
Else
Value = DefaultValue
m_ErrorCode = expInvalidInputforFunction
m_ErrorDescription = "Invalid Input for ACOS"
Error = m_ErrorCode
End If
Case opTan
Tos = Tan(Tos)
Case opAtn
Tos = Atn(Tos)
Case opAtan
Tos = Atn(Tos)
Case opSec
Tos = 1 / Cos(Tos)
Case opCosec
Tos = 1 / Sin(Tos)
Case opCotan
Tos = 1 / Tan(Tos)
Case opSin_D 'Sine in Degrees
Tos = Sin(Tos * Atn(1) / 45)
Case opCos_D 'Cos in Degrees
Tos = Cos(Tos * Atn(1) / 45)
Case opTan_D 'Tan in Degrees
Tos = Tan(Tos * Atn(1) / 45)
Case opGAMMA
Tos = Exp(GammLn(Tos))
Case opSINH
Tos = (Exp(Tos) - Exp(-Tos)) / 2
Case opcosh
Tos = (Exp(Tos) + Exp(-Tos)) / 2
Case opTANH
Tos = (Exp(Tos) - Exp(-Tos)) / (Exp(Tos) + Exp(-Tos))
Case opasinh
Tos = Log(Tos + Sqr(Tos * Tos + 1))
Case opacosh
If Tos < 1 Then
MsgBox "Acosh not defined for less than 1"
Exit Function
End If
Tos = Log(Tos + Sqr(Tos * Tos - 1))
Case opPow
Tos = stak(sp) ^ Tos
sp = sp - 1
Case opMin
If stak(sp) < Tos Then Tos = stak(sp)
sp = sp - 1
Case opMax
If stak(sp) > Tos Then Tos = stak(sp)
sp = sp - 1
Case opIIf
If stak(sp - 1) Then Tos = stak(sp)
sp = sp - 2
#If SupportStrings Then
Case opAppend
Tos = stak(sp) & Tos
sp = sp - 1
Case opLen
Tos = Len(Tos)
Case opAsc
Tos = Asc(Tos)
Case opSpace
Tos = Space$(Tos)
Case opString
Tos = String$(stak(sp), Tos)
sp = sp - 1
Case opLeft
Tos = Left$(stak(sp), Tos)
sp = sp - 1
Case opRight
Tos = Right$(stak(sp), Tos)
sp = sp - 1
Case opMid
Tos = Mid$(stak(sp - 1), stak(sp), Tos)
sp = sp - 2
Case opInstr
Tos = InStr(stak(sp - 1), stak(sp), Tos)
sp = sp - 2
#End If
Case Else
' this should never occur
Err.Raise 999, "CExpression", "Internal Error"
End Select
Next
Value = Tos
Exit Function
ValueError:
' exit with information in the Err object
' but without raising an error
' MsgBox "Error"
On Error GoTo ErrOccur
vars(0) = m_ErrorCode
Value = m_ErrorDescription
Err = m_ErrorCode
Exit Function
ErrOccur:
Err.Raise 999, "CExpression", "Internal Error"
On Error GoTo 0
End Function
' assign an expression and evaluate it in one single operation
Function Evaluate(expr As String, ParamArray vars() As Variant) As Variant
' if the value of variables is specified,
' they must appear in alphabetical order
Dim i As Integer
Expression = expr
If m_Expression = "" Or m_ErrorCode Then Exit Function
' assign values to variables
For i = LBound(vars) To UBound(vars)
If i >= m_Variables.Count Then Exit For
m_Variables(i + 1).Value = vars(i)
Next
' evaluate it
Evaluate = Value
End Function
' the expression in RPN format (read-only)
Property Get RPNExpression() As String
Dim Index As Long, result As String
Dim currItem As Variant
Dim i As Long, Char As String
' don't evaluate missing or uncorrect expressions
If m_Expression = "" Or m_ErrorCode Then Exit Property
For Index = 1 To compItems
If compOpcodes(Index) = opValue Then
' it's an operand
If IsObject(compValues(Index)) Then
' it's a variable
result = result & " " & compValues(Index).Name
#If SupportStrings Then
ElseIf VarType(compValues(Index)) = vbString Then
' it's a string constant
currItem = compValues(Index)
If InStr(currItem, """") = 0 Then
result = result & " """ & currItem & """"
ElseIf InStr(currItem, "'") = 0 Then
result = result & " '" & currItem & "'"
Else
result = result & " """
For i = 1 To Len(currItem)
Char = Mid$(currItem, i, 1)
If Char <> """" Then
result = result & Char
Else
result = result & """"""
End If
Next
result = result & """"
End If
#End If
Else
result = result & " " & Format$(compValues(Index))
End If
Else
' it is an operator
result = result & " " & opNames(compOpcodes(Index))
End If
Next
RPNExpression = result
End Property
Private Sub Class_Initialize()
' initialize all arrays
AddOpcode opStart, "", 255, 1
AddOpcode opOpenBracket, "(", 255, 1
AddOpcode opMinus, "-", 18
AddOpcode opNot, "NOT", 8
AddOpcode opEnd, vbNullChar, 0, -1
AddOpcode opComma, ",", 0, -1
AddOpcode opCloseBracket, ")", 0, -1
AddOpcode opPower, "^", 20
AddOpcode opMul, "*", 17
AddOpcode opDiv, "/", 17
AddOpcode opIntDiv, "\", 16
AddOpcode opMod, "MOD", 15
AddOpcode opAdd, "+", 14
AddOpcode opSub, "-", 14
AddOpcode opEq, "=", 10
AddOpcode opLt, "<", 10
AddOpcode opLe, "<=", 10
AddOpcode opGt, ">", 10
AddOpcode opGe, ">=", 10
AddOpcode opNe, "<>", 10
AddOpcode opAnd, "AND", 7
AddOpcode opOr, "OR", 6
AddOpcode opXor, "XOR", 6
AddOpcode opPi, "PI"
AddOpcode opdeg, "DEG", 30, 1
AddOpcode oprad, "RAD", 30, 1
AddOpcode opAbs, "ABS", 30, 1
AddOpcode opInt, "INT", 30, 1
AddOpcode opFix, "FIX", 30, 1
AddOpcode opSgn, "SGN", 30, 1
AddOpcode opSqr, "SQR", 30, 1
AddOpcode opLog, "LOG", 30, 1
AddOpcode opLn, "LN", 30, 1
AddOpcode opExp, "EXP", 30, 1
AddOpcode opSin, "SIN", 30, 1
AddOpcode opAsin, "ASIN", 30, 1
AddOpcode opCos, "COS", 30, 1
AddOpcode opAcos, "ACOS", 30, 1
AddOpcode opTan, "TAN", 30, 1
AddOpcode opAtn, "ATN", 30, 1
AddOpcode opAtan, "ATAN", 30, 1
AddOpcode opSec, "SEC", 30, 1
AddOpcode opCosec, "CSC", 30, 1
AddOpcode opCotan, "COT", 30, 1
AddOpcode opSin_D, "SIN_D", 30, 1
AddOpcode opCos_D, "COS_D", 30, 1
AddOpcode opTan_D, "TAN_D", 30, 1
AddOpcode opGAMMA, "GAMMA", 30, 1
AddOpcode opSINH, "SINH", 30, 1
AddOpcode opcosh, "COSH", 30, 1
AddOpcode opTANH, "TANH", 30, 1
AddOpcode opasinh, "ASINH", 30, 1
AddOpcode opacosh, "ACOSH", 30, 1
AddOpcode opPow, "POWER", 30, 2
AddOpcode opMin, "MIN", 30, 2
AddOpcode opMax, "MAX", 30, 2
AddOpcode opIIf, "IIF", 30, 3
#If SupportStrings Then
AddOpcode opAppend, "&", 4
AddOpcode opLen, "LEN", 30, 1
AddOpcode opAsc, "ASC", 30, 1
AddOpcode opSpace, "SPACE", 30, 1
AddOpcode opString, "STRING", 30, 2
AddOpcode opLeft, "LEFT", 30, 2
AddOpcode opRight, "RIGHT", 30, 2
AddOpcode opMid, "MID", 30, 3
AddOpcode opInstr, "INSTR", 30, 3
#End If
RaiseErrors = True
AutoCreateVariables = True
Set m_Variables = New Collection
Set m_Roots = New Collection
End Sub
' support routine used within Class_Initialize
Private Sub AddOpcode(opcode As Integer, opcodeName As String, Optional priority As Integer, Optional numArgs As Integer)
opNames(opcode) = opcodeName
opPriority(opcode) = priority
opNumArgs(opcode) = numArgs
End Sub
Function GammLn(xx)
'DefDbl I
'DEFDBL A-Z
'return the value of Log Gammma(xx)
'xx = CDBL(Xxx)
Dim yy, G, tmp, ser
Dim j As Integer
Dim cof(6) As Double, stp As Double, one As Double, half As Double
Dim fpf As Double, x As Double ', tmp AS DOUBLE
'check to see if xx is integer
yy = xx
If yy = Int(yy) Then 'an integer
G = 1
For i = 1 To yy - 1
G = G * i
Next
'
GammLn = Log(G)
Exit Function
Else
'End If
'DIM j AS INTEGER
cof(1) = 76.18009
cof(2) = -86.50532
cof(3) = 24.0141
cof(4) = -1.23174
cof(5) = 0.00120858
cof(6) = -0.00000536382
stp = 2.506628
one = 1!: half = 0.5: fpf = 5.5
x = xx - one
tmp = x + fpf
tmp = (x + half) * Log(tmp) - tmp
ser = one
For j = 1 To 6
x = x + one
ser = ser + cof(j) / x
'PRINT ser
Next
GammLn = tmp + Log(stp * ser)
End If
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -