كود :
Imports System.Collections
Module ExprManager
Private Function IsEmptyStack(ByVal AStack As Stack) As Boolean
Return (AStack.Count = 0)
End Function
Private Function IsOperator(ByVal AChar As Char) As Boolean
Return "^*/+-".Contains(AChar)
End Function
Private Function CompareOperators(ByVal Op1 As Char, ByVal Op2 As Char) As Integer
If Not (IsOperator(Op1) And IsOperator(Op2)) Then
Err.Raise(vbObjectError + 1001, "CompareOperators", "Operator(s) not suppoerted")
End If
Select Case Op1
Case "^"c
If Op2 = "^"c Then
Return 0
Else
Return 1
End If
Case "*"c, "/"c
Select Case Op2
Case "^"c
Return -1
Case "*"c, "/"c
Return 0
Case "+"c, "-"c
Return 1
End Select
Case "+"c, "-"c
Select Case Op2
Case "^"c, "*"c, "/"c
Return -1
Case "+"c, "-"c
Return 0
End Select
End Select
End Function
Private Function InfixToPostfix(ByVal InfixExpression As String) As String
Dim Infix As String
Dim Postfix As String
Dim InfixIndex As Integer
Dim InfixLen As Integer
Dim AChar As Char
Dim APeek As String
Dim ANumber As String
Dim MathStack As New Stack
Infix = InfixExpression.Trim()
If Infix = "" Then
Return ""
End If
Infix = Infix & ")"
ANumber = ""
Postfix = ""
InfixLen = Len(Infix) '- 1
InfixIndex = 0
MathStack.Clear()
MathStack.Push("(")
Do While (Not IsEmptyStack(MathStack)) And (InfixIndex <= InfixLen)
'AChar = Mid$(Infix, InfixIndex, 1)
AChar = Infix(InfixIndex)
If Char.IsDigit(AChar) Then
ANumber = ANumber & AChar
ElseIf AChar = "(" Then
If ANumber <> "" Then
Postfix = Postfix & ANumber & " "
ANumber = ""
End If
MathStack.Push(AChar)
ElseIf IsOperator(AChar) Then
If ANumber <> "" Then
Postfix = Postfix & ANumber & " "
ANumber = ""
End If
APeek = MathStack.Peek
If IsOperator(APeek) Then
Do While CompareOperators(APeek, AChar) >= 0
APeek = MathStack.Pop
Postfix = Postfix & APeek
APeek = MathStack.Peek
If Not IsOperator(APeek) Then Exit Do
Loop
End If
MathStack.Push(AChar)
ElseIf AChar = ")" Then
If ANumber <> "" Then
Postfix = Postfix & ANumber & " "
ANumber = ""
End If
APeek = MathStack.Peek
Do While APeek <> "("
APeek = MathStack.Pop
Postfix = Postfix & APeek
APeek = MathStack.Peek
Loop
MathStack.Pop()
End If
InfixIndex = InfixIndex + 1
Loop
If Not IsEmptyStack(MathStack) Then
Err.Raise(vbObjectError + 1002, "InfixToPostfix", "Invalid infix expression")
Else
InfixToPostfix = Postfix
End If
End Function
Private Function PerformOperation(ByVal Number1 As Double, ByVal Number2 As Double, ByVal AOperator As Char) As Double
Select Case AOperator
Case "+"c
Return Number1 + Number2
Case "-"c
Return Number1 - Number2
Case "*"c
Return Number1 * Number2
Case "/"c
If Number2 = 0 Then
Err.Raise(vbObjectError + 1004, "EvaluatePostfix", "Division by zero")
Else
Return Number1 / Number2
End If
Case "^"c
Return Number1 ^ Number2
Case Else
Err.Raise(vbObjectError + 1001, "CompareOperators", "Operator not suppoerted")
End Select
End Function
Private Function EvaluatePostfix(ByVal PostfixExpression As String) As Double
Dim Postfix As String
Dim ANumber As String
Dim AChar As Char
Dim PostfixIndex As Long
Dim PostfixLen As Long
Dim Num1 As Double
Dim Num2 As Double
Dim NumResult As Double
Dim MathStack As New Stack
Postfix = Trim$(PostfixExpression)
If Postfix = "" Then
Return 0.0
End If
Postfix = Postfix & "="
ANumber = ""
PostfixLen = Len(Postfix)
PostfixIndex = 0
MathStack.Clear()
Do While PostfixIndex <= PostfixLen
'AChar = Mid$(Postfix, PostfixIndex, 1)
AChar = Postfix(PostfixIndex)
If AChar = " " Then
If ANumber <> "" Then
MathStack.Push(CDbl(ANumber))
ANumber = ""
End If
ElseIf Char.IsDigit(AChar) Then
ANumber = ANumber & AChar
ElseIf AChar = "=" Then
If ANumber <> "" Then
MathStack.Push(CDbl(ANumber))
ANumber = ""
End If
If MathStack.Count = 1 Then
Return MathStack.Pop
Else
Err.Raise(vbObjectError + 1003, "EvaluatePostfix", "Invalid postfix expression")
End If
ElseIf IsOperator(AChar) Then
If ANumber <> "" Then
MathStack.Push(CDbl(ANumber))
ANumber = ""
End If
If IsEmptyStack(MathStack) Then
Err.Raise(vbObjectError + 1003, "EvaluatePostfix", "Invalid postfix expression")
Else
Num2 = MathStack.Pop
If IsEmptyStack(MathStack) Then
Err.Raise(vbObjectError + 1003, "EvaluatePostfix", "Invalid postfix expression")
Else
Num1 = MathStack.Pop
NumResult = PerformOperation(Num1, Num2, AChar)
MathStack.Push(NumResult)
End If
End If
End If
PostfixIndex = PostfixIndex + 1
Loop
End Function
Public Function EvaluateExpr(ByVal AExpr As String) As String
Dim PostfixExpr As String
AExpr = AExpr.Trim
If AExpr = "" Then Return ""
PostfixExpr = InfixToPostfix(AExpr)
Return EvaluatePostfix(PostfixExpr)
End Function
End Module