main.bas

分析数学表达式 运算 以及作图用的

Attribute VB_Name = "Main"
Option Base 1
Public InText As String
Public Type Word
  Content As String
  Type As Byte
  Disposed As Boolean
  Priority As Integer
End Type
Public MyExpression1() As String
Public MyExpression() As Word
Private NELocation As Integer, NELength As Integer
Public NowExpression1() As String
Public NowExpression() As Word
Private Function DataStyle(ByRef Dat As String) As Byte
On Error Resume Next
Select Case Dat
Case " "
  DataStyle = 0 '空格
Case "0" To "9", "."
  DataStyle = 1 '数字
Case "+", "-", "*", "/", "^"
  DataStyle = 2
Case "a" To "c"
  DataStyle = 3
Case "x" To "z"
  DataStyle = 4
Case "("
  DataStyle = 5
Case ")"
  DataStyle = 6
End Select
End Function
Public Function AddSpace(ByRef DstString As String, Text As Boolean) As String
On Error Resume Next
Dim Temp As String
Dim Fir As String, Sec As String, Thd As String
For i = 1 To Len(DstString)
  Fir = Mid(DstString, i, 1)
  Sec = Mid(DstString, i + 1, 1)
  If DataStyle(Fir) = DataStyle(Sec) And DataStyle(Fir) = 1 Then
    Temp = Temp & Fir
  ElseIf DataStyle(Fir) = 0 Or DataStyle(Sec) = 0 Then
    Temp = Temp & Fir
  Else
    Temp = Temp & Fir & " "
  End If
Next i
AddSpace = Temp & " "
If Text = True Then
  MyExpression1 = Split(AddSpace, " ")
  For i = LBound(MyExpression1) To UBound(MyExpression1)
    If DataStyle(MyExpression1(i)) = 5 And DataStyle(MyExpression1(i + 1)) = 1 And DataStyle(MyExpression1(i + 2)) = 6 Then
      MyExpression1(i) = MyExpression1(i + 1)
      For j = i To UBound(MyExpression1)
        NowExpression(j) = NowExpression(j + 2)
      Next j
    End If
  Next i
  ReDim MyExpression(LBound(MyExpression1) To UBound(MyExpression1))
  For i = LBound(MyExpression1) To UBound(MyExpression1)
  MyExpression(i).Content = MyExpression1(i)
  MyExpression(i).Type = DataStyle(MyExpression1(i))
  MyExpression(i).Disposed = False
  MyExpression(i).Priority = 0
  Next i
  Call SetPriority
Else
  NowExpression1 = Split(AddSpace, " ")
  ReDim NowExpression(LBound(NowExpression1) To UBound(NowExpression1) - 1)
  For i = LBound(NowExpression1) To UBound(NowExpression1) - 1
  NowExpression(i).Content = NowExpression1(i)
  NowExpression(i).Type = DataStyle(NowExpression1(i))
  NowExpression(i).Disposed = False
  Debug.Print NowExpression(i).Content
  Next i
End If
End Function
Private Sub SetPriority()
On Error Resume Next
For i = LBound(MyExpression1) To UBound(MyExpression1)
  If MyExpression(i).Type = 5 Then
    For j = i To UBound(MyExpression1)
      MyExpression(j).Priority = MyExpression(j).Priority + 1
    Next j
  ElseIf MyExpression(i).Type = 6 Then
    For j = i + 1 To UBound(MyExpression1)
      MyExpression(j).Priority = MyExpression(j).Priority - 1
    Next j
  End If
Next i
If MyExpression(UBound(MyExpression1)).Priority <> 0 Then
MsgBox ("左右括号数目不一，请检查")
Exit Sub
End If
r = HighestPriority
End Sub
Public Function HighestPriority() As String
On Error Resume Next
NELength = 0
Dim HP As Integer
HP = 0
HighestPriority = ""
For i = LBound(MyExpression) To UBound(MyExpression)
If MyExpression(i).Priority > HP Then HP = MyExpression(i).Priority
Next i
For i = LBound(MyExpression) To UBound(MyExpression)
If MyExpression(i).Priority = HP Then
NELocation = i + 1
HighestPriority = HighestPriority & MyExpression(NELocation).Content
Exit For
End If
Next i
i = i + 2
Do
NELength = NELength + 1
HighestPriority = HighestPriority & MyExpression(i).Content
i = i + 1
Loop While MyExpression(i).Priority = HP
NELocation = NELocation - 1
NELength = NELength + 1
HighestPriority = Left(HighestPriority, Len(HighestPriority) - 1)
HighestPriority = AddSpace(HighestPriority, False)
End Function
Public Function DoCalc() As String
On Error Resume Next
Dim NewVal As String
For i = UBound(NowExpression) To LBound(NowExpression) Step -1
  If NowExpression(i).Content = "^" Then
    NewVal = Val(NowExpression(i - 1).Content) ^ Val(NowExpression(i + 1).Content)
    NowExpression(i - 1).Content = NewVal
    NowExpression(i - 1).Type = 1
    For j = i To UBound(NowExpression)
      NowExpression(j) = NowExpression(j + 2)
    Next j
    ReDim Preserve NowExpression(LBound(NowExpression) To UBound(NowExpression) - 2)
    GoTo ExitFunction
  End If
Next i
For i = LBound(NowExpression) To UBound(NowExpression)
  If NowExpression(i).Content = "*" Or NowExpression(i).Content = "/" Then
    If NowExpression(i).Content = "*" Then
      NewVal = Val(NowExpression(i - 1).Content) * Val(NowExpression(i + 1).Content)
    Else
      NewVal = Val(NowExpression(i - 1).Content) / Val(NowExpression(i + 1).Content)
    End If
    NowExpression(i - 1).Content = NewVal
    NowExpression(i - 1).Type = 1
    For j = i To UBound(NowExpression)
      NowExpression(j) = NowExpression(j + 2)
    Next j
    ReDim Preserve NowExpression(LBound(NowExpression) To UBound(NowExpression) - 2)
    GoTo ExitFunction
  End If
Next i
For i = LBound(NowExpression) To UBound(NowExpression)
  If NowExpression(i).Content = "+" Or NowExpression(i).Content = "-" Then
    If NowExpression(i).Content = "+" Then
      NewVal = Val(NowExpression(i - 1).Content) + Val(NowExpression(i + 1).Content)
    Else
      NewVal = Val(NowExpression(i - 1).Content) - Val(NowExpression(i + 1).Content)
    End If
    NowExpression(i - 1).Content = NewVal
    NowExpression(i - 1).Type = 1
    For j = i To UBound(NowExpression)
      NowExpression(j) = NowExpression(j + 2)
    Next j
    ReDim Preserve NowExpression(LBound(NowExpression) To UBound(NowExpression) - 2)
    GoTo ExitFunction
  End If
Next i
ExitFunction:
For i = LBound(MyExpression) To NELocation
DoCalc = DoCalc & MyExpression(i).Content & " "
Next i
For i = LBound(NowExpression) To UBound(NowExpression)
DoCalc = DoCalc & NowExpression(i).Content & " "
Next i
For i = NELocation + NELength To UBound(MyExpression)
DoCalc = DoCalc & MyExpression(i).Content & " "
Next i
End Function