analyser.bas

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

Attribute VB_Name = "Module1"
Option Base 1
Private ii As Integer
Public InText As String
Private FullExpression() As String, NowExpression() As String
Private Priority() As Integer
Private FullFomula As String, NowFomula As String
Private EStart As Integer, Elength As Integer
Private HaveProblems As Boolean
Private C() As Single
Private ConstIndex
Private Type ConstInfo
  Name As String
  Val As Single
End Type
Public ConstInfo1() As ConstInfo
Public Sub InputConst(ByRef ConstName As String, ByVal ConstVal As Single)
ReDim Preserve ConstInfo1(UBound(ConstInfo1) + 1) As ConstInfo
ConstIndex = ConstIndex + 1
ConstInfo1(ConstIndex).Name = ConstName
ConstInfo1(ConstIndex).Val = ConstVal
End Sub
Private Function DataStyle(ByRef Dat As String) As Integer
On Error Resume Next
DataStyle = -1
Select Case Dat
Case " "
  DataStyle = 0 '空格
Case "0" To "9", ".", "-", "E"
  DataStyle = 1 '数字
Case "+", "_", "*", "/", "^"
  DataStyle = 2
Case "a" To "z"
  DataStyle = 3
Case "A" To "D", "F" To "Z"
  DataStyle = 4
Case "("
  DataStyle = 5
Case ")"
  DataStyle = 6
Case ""
  DataStyle = -2
End Select
End Function
Private Function AddSpace(ByRef DstString As String) As String
On Error Resume Next
Dim Temp As String
Dim Fir As String, Sec As String, Thd As String
Dim ConstNum As Integer
ConstNum = 0
DstString = LCase(DstString)
For i = 1 To Len(DstString)
  If i = 1 Then
    If DataStyle(Mid(DstString, i, 1)) = 3 And DataStyle(Mid(DstString, i + 1, 1)) <> 3 Then
      Mid(DstString, i, 1) = UCase(Mid(DstString, i, 1))
      ConstNum = ConstNum + 1
    End If
  ElseIf i = Len(DstString) Then
    If DataStyle(Mid(DstString, i, 1)) = 3 And DataStyle(Mid(DstString, i - 1, 1)) <> 3 Then
      Mid(DstString, i, 1) = UCase(Mid(DstString, i, 1))
      ConstNum = ConstNum + 1
    End If
  Else
    If DataStyle(Mid(DstString, i, 1)) = 3 And DataStyle(Mid(DstString, i - 1, 1)) <> 3 And DataStyle(Mid(DstString, i + 1, 1)) <> 3 Then
      Mid(DstString, i, 1) = UCase(Mid(DstString, i, 1))
      ConstNum = ConstNum + 1
    End If
  End If
Next i
ReDim C(1 To ConstNum)
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) = 3 And (DataStyle(Sec) = 1 Or DataStyle(Sec) = 5) Then
    Temp = Temp & Fir & " "
  ElseIf DataStyle(Fir) = 0 Or DataStyle(Sec) = 0 Then
    Temp = Temp & Fir
  ElseIf DataStyle(Fir) = 3 And DataStyle(Sec) = 3 Then
    Temp = Temp & Fir
  Else
    Temp = Temp & Fir & " "
  End If
Next i
AutoAddSpace = False
AddSpace = Temp & " "
FullFomula = AddSpace
FullExpression = Split(AddSpace, " ")
For i = UBound(FullExpression) To LBound(FullExpression) Step -1
FullExpression(i + 1) = FullExpression(i)
Next i
Call CheckForProblems
Call SetPriority
'ReDim Preserve FullExpression(1 To UBound(FullExpression) - 1)
End Function
Private Sub CheckForProblems()
HaveProblems = False
For i = 1 To UBound(FullExpression)
  If DataStyle(FullExpression(i)) = 4 Then
    For j = LBound(ConstInfo1) To UBound(ConstInfo1)
      If ConstInfo1(j).Name = FullExpression(i) Then
        FullExpression(i) = ConstInfo1(j).Val
      End If
    Next j
  End If
  If DataStyle(FullExpression(i)) = 4 Then
    HaveProblems = True
    MsgBox Join(FullExpression, " ")
    MsgBox ("不明的常数；请检查常数列表")
  End If
Next i
For i = 1 To UBound(FullExpression)
  If FullExpression(i) = "" Then
    For j = i To UBound(FullExpression) - 1
      FullExpression(j) = FullExpression(j + 1)
    Next j
  End If
Next i
    FullFomula = Join(FullExpression, " ")
For i = 1 To UBound(FullExpression) - 2
  If FullExpression(i) = "(" And IsNumeric(FullExpression(i + 1)) And FullExpression(i + 2) = ")" Then
    FullExpression(i) = FullExpression(i + 1)
    For j = i + 1 To UBound(FullExpression)
      If j + 2 <= UBound(FullExpression) Then
        FullExpression(j) = FullExpression(j + 2)
      Else
        FullExpression(j) = ""
      End If
    Next j
    FullFomula = Join(FullExpression, " ")
  End If
Next i
For i = 1 To UBound(FullExpression) - 1
  If DataStyle(FullExpression(i)) = -1 And IsNumeric(FullExpression(i)) = False Then
    MsgBox "不可辨认的字符。请检查拼写或设为常数。"
    HaveProblems = True
  End If
Next i
For i = 1 To UBound(FullExpression) - 1
  If DataStyle(FullExpression(i)) = 1 And DataStyle(FullExpression(i + 1)) = 1 Then
    MsgBox "请用运算符号连接两个数字。"
    HaveProblems = True
  End If
  If DataStyle(FullExpression(i)) = 2 And DataStyle(FullExpression(i + 1)) = 2 Then
    MsgBox "" + ", " - ", " * ", " / ", " ^ "两端是字符或表达式。"
    HaveProblems = True
  End If
  If DataStyle(FullExpression(i)) = 3 And DataStyle(FullExpression(i + 1)) = 2 Then
    MsgBox "函数后只能紧跟数字或括号"
    HaveProblems = True
  End If
Next i
FullFomula = Join(FullExpression, " ")
End Sub
Private Sub SetPriority()
Dim HPriority As Integer
ReDim Priority(1 To UBound(FullExpression))
For i = 1 To UBound(FullExpression)
Priority(i) = 1
Next i
HPriority = 1
For i = 1 To UBound(FullExpression)
  If DataStyle(FullExpression(i)) = 5 Then
    For j = i To UBound(FullExpression)
    Priority(j) = Priority(j) + 1
    Next j
    HPriority = HPriority + 1
  ElseIf DataStyle(FullExpression(i)) = 6 Then
    For j = i + 1 To UBound(FullExpression)
    Priority(j) = Priority(j) - 1
    Next j
  End If
Next i
For i = 1 To UBound(Priority)
  If Priority(i) = HPriority Then
    EStart = i
    Exit For
  End If
Next i
Elength = 0
For i = EStart + 1 To UBound(Priority)
  If Priority(i) = HPriority Then
    Elength = Elength + 1
  Else
    Exit For
  End If
Next i
NowFomula = ""
For i = EStart To EStart + Elength
  NowFomula = NowFomula & FullExpression(i) & " "
Next i
NowExpression = Split(NowFomula, " ")
End Sub
Private Function DoCalc() As String
Randomize
On Error Resume Next
Dim NewVal As String
For i = UBound(NowExpression) To LBound(NowExpression) Step -1
  Select Case NowExpression(i - 1)
  Case "sin"
    NewVal = Sin(Val(NowExpression(i)))
    NewVal = Round(NewVal, 3): If NewVal < 0.01 And NewVal > 0 Then NewVal = 0.01: If NewVal > -0.01 And NewVal < 0 Then NewVal = -0.01
    If Left(NewVal, 1) = "." Then NewVal = "0" & NewVal
    If Left(NewVal, 2) = "-." Then NewVal = "-0" & Right(NewVal, Len(NewVal) - 1)
    NowExpression(i - 1) = NewVal
    For j = i To UBound(NowExpression)
      NowExpression(j) = NowExpression(j + 1)
    Next j