Public Enum State ‘记录计算程序所在的计算状态
Algebra = 0 ‘实数计算
complex ‘复数、四元数计算
End Enum
Public Gap As Single ‘定义积分微分步长
Dim Total As Integer
Dim Formulae() As String
Dim FormulaNames() As String
Dim MathsState As State
‘总体计算控制模块
Public Function MathsCompute(ByVal Inputs As String) As String ‘所有运算的总入口，负责数学式的规范化
Dim Lens As Integer
Dim I As Integer
Dim TempFormula As String
Dim CalculateFormula() As Integer ‘记录要计算的数学式的编号
Dim T As Integer
Dim J As Integer
Dim strTmpA As String, strTmpB As String
MathsState = Algebra ‘计算状态初始化
J = 0 ‘函数记录初始化
Total = 0
ReDim Formulae(0)
ReDim FormulaNames(0)
If Len(Trim(Inputs)) = 0 Then Exit Function ‘判断输入是否为空
If Asc(Right(Inputs, 2)) <> 13 And Asc(Right(Inputs, 1)) <> 10 Then Inputs = Inputs & Chr(13) & Chr(10) ‘规范输入的数学式组
Inputs = Replace(Inputs, ")(", ")*(") ‘缩写规范化
Inputs = Replace(Inputs, "][", "]*[")
Inputs = Replace(Inputs, "()", "(0)") ‘检测空括号
Inputs = Replace(Inputs, "[]", "[0]")
Lens = Len(Inputs)
If InStr(Inputs, "[") > 0 Then
If InStr(Inputs, "]") > 0 Then
MathsState = complex
Else
MsgBox "您输入的复数有问题，请检查您的输入！", vbOKOnly, "ZL计算系统"
End If
End If
For I = 1 To Lens – 1 ‘提取每组数学式信息
strTmpA = Mid(Inputs, I, 1)
If MathsState = Algebra Then ‘判断是否是复数运算
If strTmpA = "i" Or strTmpA = "j" Or strTmpA = "k" Then
If I = 1 Then
strTmpB = Mid(Inputs, 2, 1)
If CheckFun(strTmpB) Or strTmpB = " " Or Asc(strTmpB) = 13 Or Tmp = "!" Then MathsState = complex
Else
strTmpB = Mid(Inputs, I – 1, 1)
If CheckFun(strTmpB) Or strTmpB = " " Or Asc(strTmpB) = 10 Or strTmpB = "(" Or strTmpB = CStr(Val(strTmpB)) Or strTmpB = "," Then
strTmpB = Mid(Inputs, I + 1, 1)
If CheckFun(strTmpB) Or strTmpB = " " Or Asc(strTmpB) = 13 Or strTmpB = ")" Or strTmpB = "," Or strTmpB = "!" Then MathsState = complex
End If
End If
End If
End If
If Asc(Mid(Inputs, I, 1)) = 13 Then
If Asc(Mid(Inputs, I + 1, 1)) = 10 Then
Total = Total + 1
ReDim Preserve Formulae(Total)
ReDim Preserve FormulaNames(Total)
TempFormula = Mid(Inputs, J + 1, I – J – 1)
For T = 2 To Len(TempFormula)
If Mid(TempFormula, T – 1, 2) = ")=" Or Mid(TempFormula, T, 1) = ":" Then Exit For
Next T
If T < Len(TempFormula) Then
FormulaNames(Total) = Trim(Left(TempFormula, T – 1))
Formulae(Total) = Trim(Right(TempFormula, Len(TempFormula) – T))
Else
FormulaNames(Total) = "CALCULATE"
Formulae(Total) = Trim(TempFormula)
End If
J = I + 1
End If
End If
Next I
If InStr(LCase(Inputs), "complex:") > 0 Then MathsState = complex
‘把定义式和要计算的式分开
T = 0
For I = 1 To Total ‘检查有多少需要计算的式子
Select Case LCase(FormulaNames(I))
Case "calculate", "complex" ‘计算
T = T + 1
ReDim Preserve CalculateFormula(T)
CalculateFormula(T) = I
MathsCompute = MathsCompute & Formulae(I) & "=" & Trim(CStr(MathsCalculate(Formulae(I)))) & ";" ‘开始计算
Case "gap" ‘设置积分间隔
Gap = Val(Formulae(I))
End Select
Next I
‘状态还原
MathsState = Algebra
Gap = 0.0002
End Function
Public Function FormulaCalculate(ByVal Inputs As String, Optional ByVal CalState As State = Algebra) As Variant ‘转换函数为MATHSCALCULATE可读方式和自定义常数处理
If MathsState = Algebra And CalState = Algebra Then
FormulaCalculate = AlgebraFormulaCalculate(Inputs)
ElseIf MathsState = complex Or CalState = complex Then
Set FormulaCalculate = ComplexFormulaCalculate(Inputs)
End If
End Function
Private Function AlgebraFormulaCalculate(ByVal Inputs As String) As Double ‘实数用转换函数为MATHSCALCULATE可读方式和自定义常数处理
Dim Lens As Integer
Lens = Len(Inputs)
Dim I As Integer
Dim J As Integer
Dim T As Integer
Dim Tmp As String
Dim Params As String ‘记录自定义函数参数序列
Dim Numbers As String ‘记录输入数值序列
Dim TmpParam() As String
For I = 1 To Lens
If Mid(Inputs, I, 1) = "(" Then Exit For
Next I
If I < Lens – 1 Then
Tmp = Left(Inputs, I – 1)
Numbers = Mid(Inputs, Len(Tmp) + 2, Len(Inputs) – Len(Tmp) – 2)
If Right(Numbers, 1) <> "," Then Numbers = Numbers & ","
For J = 1 To Total
If LCase(Left(FormulaNames(J), 1 + Len(Tmp))) = LCase(Tmp) & "(" Then ‘和自定义函数进行比较
Params = Mid(FormulaNames(J), Len(Tmp) + 2, Len(FormulaNames(J)) – Len(Tmp) – 2)
Tmp = Formulae(J) & "@"
If Right(Params, 1) <> "," Then Params = Params & "," ‘规范化参数
Exit For
End If
Next J
‘开始检测自定义函数的参数序列和所给的数值序列是否匹配
J = 0
T = 0
For I = 1 To Len(Numbers)
If Mid(Numbers, I, 1) = "," Then
J = J + 1
ReDim Preserve TmpParam(J)
TmpParam(J) = "=" & Mid(Numbers, T + 1, I – T – 1) & ";"
T = I
End If
Next I
For I = 1 To Len(Params)
If Mid(Params, I, 1) = "," Then J = J – 1
Next I
‘开始组合参数
T = 0
For I = 1 To Len(Params)
If Mid(Params, I, 1) = "," Then
J = J + 1
TmpParam(J) = Mid(Params, T + 1, I – T – 1) & TmpParam(J)
T = I
End If
Next I
For I = 1 To J
Tmp = Tmp & TmpParam(I)
Next I
AlgebraFormulaCalculate = MathsCalculate(Tmp)
Else ‘常数处理模块
AlgebraFormulaCalculate = innerConst(Inputs)
For I = 1 To Total ‘检测用户自定义常数表，可覆盖预定义常数
If FormulaNames(I) = Inputs Then
AlgebraFormulaCalculate = Val(Deal(Formulae(I)))
Exit For
End If
Next I
End If
End Function
Private Function ComplexFormulaCalculate(ByVal Inputs As String) As ComplexNumber ‘复数用转换函数为MATHSCALCULATE可读方式和自定义常数处理
Dim Lens As Integer
Lens = Len(Inputs)
Dim I As Integer
Dim J As Integer
Dim T As Integer
Dim Tmp As String
Dim Params As String ‘记录自定义函数参数序列
Dim Numbers As String ‘记录输入数值序列
Dim TmpParam() As String
For I = 1 To Lens
If Mid(Inputs, I, 1) = "(" Then Exit For
Next I
If I < Lens – 1 Then
Tmp = Left(Inputs, I – 1)
Numbers = Mid(Inputs, Len(Tmp) + 2, Len(Inputs) – Len(Tmp) – 2)
If Right(Numbers, 1) <> "," Then Numbers = Numbers & ","
For J = 1 To Total
If LCase(Left(FormulaNames(J), 1 + Len(Tmp))) = LCase(Tmp) & "(" Then ‘和自定义函数进行比较
Params = Mid(FormulaNames(J), Len(Tmp) + 2, Len(FormulaNames(J)) – Len(Tmp) – 2)
Tmp = Formulae(J) & "@"
If Right(Params, 1) <> "," Then Params = Params & "," ‘规范化参数
Exit For
End If
Next J
‘开始检测自定义函数的参数序列和所给的数值序列是否匹配
J = 0
T = 0
For I = 1 To Len(Numbers)
If Mid(Numbers, I, 1) = "," Then
J = J + 1
ReDim Preserve TmpParam(J)
TmpParam(J) = "=" & Mid(Numbers, T + 1, I – T – 1) & ";"
T = I
End If
Next I
For I = 1 To Len(Params)
If Mid(Params, I, 1) = "," Then J = J – 1
Next I
‘开始组合参数
T = 0
For I = 1 To Len(Params)
If Mid(Params, I, 1) = "," Then
J = J + 1
TmpParam(J) = Mid(Params, T + 1, I – T – 1) & TmpParam(J)
T = I
End If
Next I
For I = 1 To J
Tmp = Tmp & TmpParam(I)
Next I
Set ComplexFormulaCalculate = MathsCalculate(Tmp)
Else ‘常数处理模块
Set ComplexFormulaCalculate = New ComplexNumber
ComplexFormulaCalculate.ePart = innerConst(Inputs)
For I = 1 To Total ‘检测用户自定义常数表，可覆盖预定义常数
If FormulaNames(I) = Inputs Then
Set ComplexFormulaCalculate = ComplexDeal(Formulae(I))
Exit For
End If
Next I
End If
End Function
Public Function MathsCalculate(ByVal Inputs As String) As Variant ‘代数式和函数的计算入口
Dim I As Integer
Dim J As Integer
Dim T As Integer
Dim Lens As Integer
Lens = Len(Inputs)
J = 0
If InStr(Inputs, "@") > 0 Then
For I = 1 To Lens
If Mid(Inputs, I, 1) = "@" Then J = J + 1: T = I
Next I
End If
If J = 0 Then
If MathsState = Algebra Then
MathsCalculate = Deal(Inputs)
ElseIf MathsState = complex Then
Set MathsCalculate = Deal(Inputs)
End If
ElseIf J = 1 Then
If MathsState = Algebra Then
MathsCalculate = Formula(Trim(Left(Inputs, T – 1)), Trim(Right(Inputs, Lens – T)))
ElseIf MathsState = complex Then
Set MathsCalculate = Formula(Trim(Left(Inputs, T – 1)), Trim(Right(Inputs, Lens – T)))
End If
Else
MsgBox "您输入的数学公式错误！", vbOKOnly, "ZL计算系统"
End If
End Function
‘总体控制模块结束
‘内置常数模块
Public Function innerConst(ByVal Inputs As String) As Double ‘为公开模块
Select Case Inputs
Case "pi", "math.pi", "Math.pi"
innerConst = Atn(1) * 4
Case "E", "math.e", "Math.e"
innerConst = Exp(1)
Case "c", "phy.c", "Phy.c"
innerConst = 299792458#
Case "G", "phy.G", "Phy.G"
innerConst = 0.00000000006672
Case "g", "phy.g", "Phy.g"
innerConst = 9.807
Case "h", "phy.h", "Phy.h"
innerConst = 6.626176E-34
Case "hb", "phy.hb", "Phy.hb"
innerConst = 6.626176E-34 / (Atn(1) * 8)
Case "Na", "Che.Na", "cha.Na", "Phy.Na", "phy.Na"
innerConst = 6.022142E+23
Case "K", "phy.K", "Phy.K"
innerConst = 1.3806503E-23
Case "R", "phy.R", "Phy.R"
innerConst = 8.31447
Case "e", "phy.e", "Phy.e"
innerConst = 1.602176E-19
Case "me", "phy.me", "Phy.me"
innerConst = 9.10938189E-31
Case "mp", "phy.mp", "Phy.mp"
innerConst = 1.67262158E-27
Case "mn", "phy.mn", "Phy.mn"
innerConst = 1.6749286E-27
Case Else
innerConst = 0
End Select
End Function
‘内置常数模块结束
‘连续运算模块
Public Function ContinumCalculate(ByVal Inputs As String, ByVal Var As String, ByVal Start As Double, ByVal Finish As Double, ByVal Kind As Boolean, ByVal Integral As Boolean) As Double
‘连续运算总入口，负责各种连续运算的分类
‘KIND真为连乘，KIND假为连加；INTEGRAL真为积分，假为普通连加
Dim I As Double, J As Integer
Dim Lens As Integer
Lens = Len(Var)
Dim Lengs As Integer
Dim TmpA As String, TmpB As String
Dim Tmp As String
Dim Answer As Double
Dim Result As Double
Answer = 0
If Kind Then Answer = 1
Dim STP As Single
STP = 1
If Integral Then STP = Gap
If STP = 0 Then STP = 0.0002
Tmp = Inputs
For I = Start To Finish Step STP
Inputs = Tmp
Lengs = Len(Inputs)
If Lengs > Lens Then
TmpA = Mid(Inputs, Lens + 1, 1)
If LCase(Left(Inputs, Lens)) = LCase(Var) And (CheckFun(TmpA) Or TmpA = "!") Then
Inputs = Str(I) & Right(Inputs, Lengs – Lens)
End If
Lengs = Len(Inputs)
J = 2
Do While J < Lengs
TmpA = Mid(Inputs, Lens + J, 1)
TmpB = Mid(Inputs, J – 1, 1)
If LCase(Mid(Inputs, J, Lens)) = LCase(Var) And (CheckFun(TmpA) Or TmpA = "!" Or TmpA = ")") And (CheckFun(TmpB) Or TmpB = "(") Then
Inputs = Left(Inputs, J – 1) & Str(I) & Right(Inputs, Lengs – Lens – J + 1)
Lengs = Len(Inputs)
End If
J = J + 1
Loop
TmpB = Mid(Inputs, Lengs – Lens, 1)
If LCase(Right(Inputs, Lens)) = LCase(Var) And CheckFun(TmpB) Then
Inputs = Left(Inputs, Lengs – Lens) & Str(I)
End If
Lengs = Len(Inputs)
ElseIf Lengs = Lens Then
Inputs = Str(I)
End If
Result = MathsCalculate(Inputs)
If Kind Then
Answer = Answer * (Result ^ STP)
Else
Answer = Answer + Result * STP
End If
Next I
ContinumCalculate = Answer
End Function
Public Function CContinumCalculate(ByVal Inputs As String, ByVal Var As String, ByVal Start As ComplexNumber, ByVal Finish As ComplexNumber, ByVal Kind As Boolean, ByVal Integral As Boolean) As ComplexNumber
‘复数与四元数连续运算总入口，负责各种连续运算的分类
‘KIND真为连乘，KIND假为连加；INTEGRAL真为积分，假为普通连加
Dim STP As Single
STP = 1
If Integral Then STP = Gap
If STP = 0 Then STP = 0.0002
Dim Direction As ComplexNumber
Set Direction = CMute(Finish, Start)
Dim Tmp As Double
Tmp = Direction.Modulus
If Tmp = 0 Then Set CContinumCalculate = Direction: Exit Function
Direction.ePart = Direction.ePart / Tmp * STP
Direction.iPart = Direction.iPart / Tmp * STP
Direction.jPart = Direction.jPart / Tmp * STP
Direction.kPart = Direction.kPart / Tmp * STP
Dim I As Double
Dim Result As New ComplexNumber, Answer As New ComplexNumber
If Kind Then Answer.ePart = 1
Dim Temp As New ComplexNumber
Temp.ePart = Start.ePart
Temp.iPart = Start.iPart
Temp.jPart = Start.jPart
Temp.kPart = Start.kPart
Dim Forum As String
For I = 0 To Tmp Step STP
Forum = AdReplace(Inputs, Var, Temp)
Set Result = Deal(Forum)
If Integral Then
Set Answer = CPlus(Answer, CMultiply(Result, Direction))
Else
If Kind Then
Set Answer = CMultiply(Answer, Result)
Else
Set Answer = CPlus(Answer, Result)
End If
End If
Temp.ePart = Temp.ePart + Direction.ePart
Temp.iPart = Temp.iPart + Direction.iPart
Temp.jPart = Temp.jPart + Direction.jPart
Temp.kPart = Temp.kPart + Direction.kPart
Next I
Set CContinumCalculate = Answer
End Function
Public Function DiffInterface(ByVal Inputs As String) As Double ‘微分计算入口
Dim A(1) As Integer
Dim I As Integer, J As Integer
Dim Lens As Integer
Lens = Len(Inputs)
J = 0
For I = 1 To Lens
If J = 2 Then Exit For
If Mid(Inputs, I, 1) = "," Then
A(J) = I
J = J + 1
End If
Next I
DiffInterface = Differential(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), Deal(Right(Inputs, Lens – A(1))))
End Function
Public Function CDiffInterface(ByVal Inputs As String) As ComplexNumber ‘复数微分计算入口
Dim A(2) As Integer
Dim I As Integer, J As Integer
Dim Lens As Integer
Lens = Len(Inputs)
J = 0
For I = 1 To Lens
If J = 3 Then Exit For
If Mid(Inputs, I, 1) = "," Then
A(J) = I
J = J + 1
End If
Next I
If A(2) = 0 Then
Set CDiffInterface = CDifferential(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), Deal(Right(Inputs, Lens – A(1))))
Else
Set CDiffInterface = CDifferential(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), Deal(Mid(Inputs, A(1) + 1, A(2) – A(1) – 1)), Deal(Right(Inputs, Lens – A(2))))
End If
End Function
Public Function Differential(ByVal Inputs As String, ByVal Var As String, ByVal Values As Single) As Double ‘微分运算
Dim I As Double, J As Integer
Dim Lens As Integer
Lens = Len(Var)
Dim Lengs As Integer
Dim TmpA As String, TmpB As String
Dim Tmp As String
Dim Answer As Double
Answer = 0
Dim Result As Double
Dim IsFirst As Boolean
IsFirst = True
Dim STP As Single
STP = Gap
If STP = 0 Then STP = 0.0002
Tmp = Inputs
For I = Values To Values + STP Step STP
Inputs = Tmp
Lengs = Len(Inputs)
If Lengs > Lens Then
TmpA = Mid(Inputs, Lens + 1, 1)
If LCase(Left(Inputs, Lens)) = LCase(Var) And (CheckFun(TmpA) Or TmpA = "!") Then
Inputs = Str(I) & Right(Inputs, Lengs – Lens)
End If
Lengs = Len(Inputs)
J = 2
Do While J < Lengs
TmpA = Mid(Inputs, Lens + J, 1)
TmpB = Mid(Inputs, J – 1, 1)
If LCase(Mid(Inputs, J, Lens)) = LCase(Var) And (CheckFun(TmpA) Or TmpA = "!" Or TmpA = ")") And (CheckFun(TmpB) Or TmpB = "(") Then
Inputs = Left(Inputs, J – 1) & Str(I) & Right(Inputs, Lengs – Lens – J + 1)
Lengs = Len(Inputs)
End If
J = J + 1
Loop
TmpB = Mid(Inputs, Lengs – Lens, 1)
If LCase(Right(Inputs, Lens)) = LCase(Var) And CheckFun(TmpB) Then
Inputs = Left(Inputs, Lengs – Lens) & Str(I)
End If
Lengs = Len(Inputs)
ElseIf Lengs = Lens Then
Inputs = Str(I)
End If
Result = MathsCalculate(Inputs)
If IsFirst Then
Answer = Result
IsFirst = False
Else
Answer = (Result – Answer) / STP
End If
Next I
Differential = Answer
End Function
Public Function CDifferential(ByVal Inputs As String, ByVal Var As String, ByVal Values As ComplexNumber, Optional ByVal Direction As ComplexNumber) As ComplexNumber ‘复数微分运算
Dim TmpA As String, TmpB As String
Dim Tmp As String
Dim Answer As New ComplexNumber
Dim Result As New ComplexNumber
Dim STP As Single
If Direction Is Nothing Then Set Direction = New ComplexNumber
If Direction.Modulus = 0 Then Set Direction = NewCNum("1")
STP = Gap
If STP = 0 Then STP = 0.0002
If Direction.Modulus <> 1 Then
Set Direction = CDivision(Direction, NewCNum(CStr(Direction.Modulus)))
End If
Set Direction = CMultiply(Direction, NewCNum(CStr(STP)))
TmpA = AdReplace(Inputs, Var, Values)
TmpB = AdReplace(Inputs, Var, CPlus(Values, Direction))
Set Answer = ComplexDeal(TmpA)
Set Result = ComplexDeal(TmpB)
Set CDifferential = CMute(Result, Answer)
Set CDifferential = CDivision(CDifferential, Direction)
End Function
Public Function CPInterface(ByVal Inputs As String, Optional ByVal CalState As State = Algebra) As Variant ‘连加入口
Dim A(2) As Integer
Dim I As Integer, J As Integer
Dim Lens As Integer
Lens = Len(Inputs)
J = 0
For I = 1 To Lens
If J = 3 Then Exit For
If Mid(Inputs, I, 1) = "," Then
A(J) = I
J = J + 1
End If
Next I
If MathsState = Algebra And CalState = Algebra Then
CPInterface = ContinumCalculate(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), Deal(Mid(Inputs, A(1) + 1, A(2) – A(1) – 1)), Deal(Right(Inputs, Lens – A(2))), False, False)
ElseIf MathsState = complex Or CalState = complex Then
Set CPInterface = CContinumCalculate(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), NewCNum(Deal(Mid(Inputs, A(1) + 1, A(2) – A(1) – 1))), NewCNum(Deal(Right(Inputs, Lens – A(2)))), False, False)
End If
End Function
Public Function CTInterface(ByVal Inputs As String, Optional ByVal CalState As State = Algebra) As Variant ‘连乘入口
Dim A(2) As Integer
Dim I As Integer, J As Integer
Dim Lens As Integer
Lens = Len(Inputs)
J = 0
For I = 1 To Lens
If J = 3 Then Exit For
If Mid(Inputs, I, 1) = "," Then
A(J) = I
J = J + 1
End If
Next I
If MathsState = Algebra And CalState = Algebra Then
CTInterface = ContinumCalculate(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), Deal(Mid(Inputs, A(1) + 1, A(2) – A(1) – 1)), Deal(Right(Inputs, Lens – A(2))), True, False)
ElseIf MathsState = complex Or CalState = complex Then
Set CTInterface = CContinumCalculate(Left(Inputs, A(0) – 1), Mid(Inputs, A(0) + 1, A(1) – A(0) – 1), NewCNum(Deal(Mid(Inputs, A(1) + 1, A(2) – A(1) – 1))), NewCNum(Deal(Right(Inputs, Lens – A(2)))), True, False)
End If
End Function
Public Function IntegralInterface(ByVal Inputs As String, Optional ByVal CalState As State = Algebra) As Variant ‘积分入口
Dim A(2) As Integer
Dim B(3) As String
Dim I As Integer, J As Integer
Dim Lens As Integer
Lens = Len(Inputs)
J = 0
For I = 1 To Lens
If J = 3 Then Exit For
If Mid(Inputs, I, 1) = "," Then
A(J) = I
J = J + 1
End If
Next I
B(0) = Left(Inputs, A(0) – 1)
B(1) = Mid(Inputs, A(0) + 1, A(1) – A(0) – 1)
B(2) = Mid(Inputs, A(1) + 1, A(2) – A(1) – 1)
B(3) = Right(Inputs, Lens – A(2))
If MathsState = Algebra And CalState = Algebra Then
IntegralInterface = ContinumCalculate(B(0), B(1), Deal(B(2)), Deal(B(3)), False, True)
ElseIf MathsState = complex Or CalState = complex Then
Set IntegralInterface = CContinumCalculate(B(0), B(1), NewCNum(Deal(B(2))), NewCNum(Deal(B(3))), False, True)
End If
End Function
‘连续运算模块结束
‘比较计算模块
Public Function Realation(ByVal Inputs As String) As Boolean ‘为二元运算项，公开模块
Dim I As Integer, J As Integer
Dim PartA As String, PartB As String ‘记录判断双方
Dim AnsA As Double, AnsB As Double ‘记录双方结果
Dim isBio As Boolean ‘记录是否是双符号
Dim isOpe As Boolean ‘记录是否是判断符号
isBio = False
isOpe = False
For I = 1 To Len(Inputs) – 1 ‘将判断双方分离
Select Case Mid(Inputs, I, 2)
Case "<>"
PartA = Trim(Left(Inputs, I – 1))
PartB = Trim(Right(Inputs, Len(Inputs) – I – 1))
J = 1
isBio = True
isOpe = True
Case ">=", "=>"
PartA = Trim(Left(Inputs, I – 1))
PartB = Trim(Right(Inputs, Len(Inputs) – I – 1))
J = 2
isOpe = True
isBio = True
Case "<=", "=<"
PartA = Trim(Left(Inputs, I – 1))
PartB = Trim(Right(Inputs, Len(Inputs) – I – 1))
J = 3
isOpe = True
isBio = True
End Select
If Not isBio Then
Select Case Mid(Inputs, I, 1)
Case "="
PartA = Trim(Left(Inputs, I – 1))
PartB = Trim(Right(Inputs, Len(Inputs) – I))
J = 4
isOpe = True
Case "<"
PartA = Trim(Left(Inputs, I – 1))
PartB = Trim(Right(Inputs, Len(Inputs) – I))
J = 5
isOpe = True
Case ">"
PartA = Trim(Left(Inputs, I – 1))
PartB = Trim(Right(Inputs, Len(Inputs) – I))
J = 6
isOpe = True
End Select
If isOpe Then Exit For
End If
Next I
AnsA = Deal(PartA)
AnsB = Deal(PartB)
Realation = False
Select Case J
Case 1
If AnsA <> AnsB Then Realation = True
Case 2
If AnsA >= AnsB Then Realation = True
Case 3
If AnsA <= AnsB Then Realation = True
Case 4
If AnsA = AnsB Then Realation = True
Case 5
If AnsA < AnsB Then Realation = True
Case 6
If AnsA > AnsB Then Realation = True
Case Else
End Select
End Function
‘比较模块结束
‘最值计算模块
Public Function Max(ByVal Inputs As String) As Double ‘计算最大值
Dim TmpA() As String
Dim TmpB As Double
Dim I As Integer
Dim Checked As Boolean
Checked = False
Inputs = Trim(Inputs)
If Right(Inputs, 1) = ";" Then Inputs = Left(Inputs, Len(Inputs) – 1)
TmpA = Split(Inputs, ";")
For I = 0 To UBound(TmpA)
TmpB = Deal(TmpA(I))
If Checked = False Then Max = TmpB: Checked = True
If TmpB > Max Then Max = TmpB
Next I
End Function
Public Function Min(ByVal Inputs As String) As Double ‘计算最小值
Dim TmpA() As String
Dim TmpB As Double
Dim I As Integer
Dim Checked As Boolean
Checked = False
Inputs = Trim(Inputs)
If Right(Inputs, 1) = ";" Then Inputs = Left(Inputs, Len(Inputs) – 1)
TmpA = Split(Inputs, ";")
For I = 0 To UBound(TmpA)
TmpB = Deal(TmpA(I))
If Checked = False Then Min = TmpB: Checked = True
If TmpB < Min Then Min = TmpB
Next I
End Function
‘最值计算模块结束
‘运算核心模块
Public Function Deal(ByVal Inputs As String, Optional ByVal CalState As State = Algebra) As Variant ‘内核基本运算计算模块总入口
If MathsState = Algebra And CalState = Algebra Then
Deal = AlgebraDeal(Inputs)
ElseIf MathsState = complex Or CalState = complex Then
Set Deal = ComplexDeal(Inputs)
End If
End Function
Public Function AlgebraDeal(ByVal Inputs As String) As Double ‘实数内核基本运算计算模块
Dim Tmp As Integer ‘记录括号层次
Tmp = 0
Dim Funs As Integer ‘记录算符数目
Dim FunF() As String ‘记录算符性质
Dim FunP() As Integer ‘记录算符位置
Dim Nums() As Double ‘记录运算数据
Dim Lens As Integer
Lens = Len(Inputs)
Dim I As Integer
Dim Tp As String
Dim Temp As Double
Dim J As Integer
For I = 1 To Lens ‘算符和数据提取部分
Tp = Mid(Inputs, I, 1)
If Tp = "(" Then
Tmp = Tmp + 1
End If
If Tp = ")" Then
Tmp = Tmp – 1
End If
If CheckFun(Tp) And Tmp = 0 Then
Funs = Funs + 1
ReDim Preserve FunF(Funs)
FunF(Funs) = Tp
ReDim Preserve FunP(Funs)
FunP(Funs) = I
If Tp = "E" Then I = I + 1
End If
Next I
If Tmp > 0 Or Tmp < -1 Then ‘对函数嵌套会有-1的差距
MsgBox "您输入的计算式括号组不封闭，请重新输入！", vbOKOnly, "ZL计算系统"
Exit Function
End If
ReDim Nums(Funs + 1)
ReDim Preserve FunP(Funs + 1)
FunP(Funs + 1) = Len(Inputs) + 1
ReDim Preserve FunF(Funs + 1)
FunF(Funs + 1) = ""
If Funs > 0 Then
For I = 1 To Funs + 1
If FunP(I) = FunP(I – 1) + 1 And Not (I = 1 And (FunF(1) = "-" Or FunF(1) = "+")) And Not ((FunF(I) = "-" Or FunF(I) = "+") And FunF(I – 1) = "E") Then
MsgBox "您输入的计算式不正确，请重新输入！", vbOKOnly, "ZL计算系统"
Exit For
End If
Tp = Trim(Mid(Inputs, FunP(I – 1) + 1, FunP(I) – FunP(I – 1) – 1))
If Mid(Tp, 1, 1) = "(" Then
Nums(I) = AlgebraDeal(Mid(Tp, 2, Len(Tp) – 2))
Else
Nums(I) = AlgebraCalculate(Tp)
End If
Next I
Else
Nums(1) = AlgebraCalculate(Trim(Inputs))
End If
‘运算部分
‘科学计数法
I = 1
Do While I <= Funs
If FunF(I) = "E" Then
Temp = Nums(I) * (10 ^ Nums(I + 1))
End If
If FunF(I) = "E" Then
Nums(I) = Temp
For J = I + 1 To Funs ‘把计算完的部分剔除
FunF(J – 1) = FunF(J)
Nums(J) = Nums(J + 1)
Next J
Funs = Funs – 1
Else
I = I + 1
End If
Loop
‘与、或、异或的运算
I = 1
Do While I <= Funs
If FunF(I) = "&" Then
Temp = Nums(I) And Nums(I + 1)
End If
If FunF(I) = "|" Then
Temp = Nums(I) Or Nums(I + 1)
End If
If FunF(I) = "#" Then
Temp = Nums(I) Xor Nums(I + 1)
End If
If FunF(I) = "&" Or FunF(I) = "|" Or FunF(I) = "#" Then
Nums(I) = Temp
For J = I + 1 To Funs ‘把计算完的部分剔除
FunF(J – 1) = FunF(J)
Nums(J) = Nums(J + 1)
Next J
Funs = Funs – 1
Else
I = I + 1
End If
Loop
‘开方和乘方运算
I = 1
Do While I <= Funs
If FunF(I) = "^" Then
Temp = Nums(I) ^ Nums(I + 1)
End If
If FunF(I) = "" Then
Temp = Nums(I) ^ (1 / Nums(I + 1))
End If
If FunF(I) = "^" Or FunF(I) = "" Then
Nums(I) = Temp
For J = I + 1 To Funs ‘把计算完的部分剔除
FunF(J – 1) = FunF(J)
Nums(J) = Nums(J + 1)
Next J
Funs = Funs – 1
Else
I = I + 1
End If
Loop
‘乘法和除法运算
I = 1
Do While I <= Funs
If FunF(I) = "*" Then
Temp = Nums(I) * Nums(I + 1)
End If
If FunF(I) = "/" Then
If Nums(I + 1) = 0 Then
MsgBox "计算中出现0除数！请检查方程！", vbOKOnly, "ZL计算系统"
Exit Function
End If
Temp = Nums(I) / Nums(I + 1)
End If
If FunF(I) = "*" Or FunF(I) = "/" Then
Nums(I) = Temp
For J = I + 1 To Funs ‘把计算完的部分剔除
FunF(J – 1) = FunF(J)
Nums(J) = Nums(J + 1)
Next J
Funs = Funs – 1
Else
I = I + 1
End If
Loop
‘加法和减法运算
I = 1
Do While I <= Funs
If FunF(I) = "+" Then
Temp = Nums(I) + Nums(I + 1)
End If
If FunF(I) = "-" Then
Temp = Nums(I) – Nums(I + 1)
End If
If FunF(I) = "+" Or FunF(I) = "-" Then
Nums(I) = Temp
For J = I + 1 To Funs ‘把计算完的部分剔除
FunF(J – 1) = FunF(J)
Nums(J) = Nums(J + 1)
Next J
Funs = Funs – 1
Else
I = I + 1
End If
Loop
AlgebraDeal = Nums(1)
End Function
LostAbaddon 