module3.bas

vb 24点计算.是一个智力小游戏

Attribute VB_Name = "TextOperator"
Dim strtext As String     '表达式
Dim ops(20) As String     '运算符数组
Dim ops_top As Integer    '指向运算符数组栈顶
Public opds(20) As Single '数值数组
Dim opds_top As Integer   '指向数值数组栈顶

'表达式的计算：其算法思想源学校发的<<数据结构(C语言版)>>中的3.1.3节

Function OperatorFunction(Operator As String) As String
 Dim a As Single
 Dim b As Single
 Dim sy As String
 Dim symb As String
 strtext = Trim$(Operator + "#")  '表达式以 # 作为结束符
  ops_top = -1  '初始化运算符数组指针
 opds_top = -1  '初始化数值数组指针
 push_ops ("#")  '# 进栈 作为运算符数组的最底部
 
 symb = getch()  '获得一关健字
 
 While ((symb <> "#") Or (ops(ops_top) <> "#"))   '如果获得的关健字不是表达式的结束符 或 从运算符数组得到的字符不是 # 则执行下面的循环步骤
 
    If ((symb <> "+") And (symb <> "-") And (symb <> "*") And (symb <> "/") And (symb <> "(") And (symb <> ")") And (symb <> "#") And (symb <> "")) Then
      push_opds (symb)      '数字进栈
      symb = getch()       '再获得一下关健字
    Else                   '如果获得的是运算符，则执行下面的步骤
        Select Case relation(ops(ops_top), symb)   '将新获得的运算符跟运算符数组栈顶的相比较
           Case "<"            'ops(ops_top)<symb 则进栈
             push_ops (symb)
             symb = getch()    '再获得一下关健字

           Case "="            'ops(ops_top)=symb 则出栈
             sy = pop_ops()
             symb = getch()    '获得一下关健字

           Case ">"            'ops(ops_top)>symb 则出栈
             sy = pop_ops()   '从运算符数组栈顶中获得一运算符
            
             If sy = "" Then '如果获得的运算符为空 则说明表达式的格式有错 返回出错消息 退出函数
               OperatorFunction = "表达式出错"
               Exit Function
             End If
           
             b = pop_opds() '从数值数组栈顶获得一数字赋值给变量 b
             a = pop_opds() '再从数值数组栈顶获得一数字赋值给变量 a
             On Error GoTo erroroccured
    
             If ((sy <> "+") And (sy <> "-") And (sy <> "*") And (sy <> "/")) Or (sy = "/" And b = 0) Then
               OperatorFunction = "表达式出错"
               Exit Function
             End If
             
             opds_top = opds_top + 1 '数值数组栈顶指针向上移一位
             opds(opds_top) = operate(a, sy, b)  '运算后进栈
          
            Case ""    'ops(ops_top) 与 symb 比较返回一个空值 那么执行下面的步骤
               OperatorFunction = "表达式出错"
               Exit Function
          End Select
     
     End If
 Wend
  
 If opds_top = 0 Then ' 最后如果运算没有出错的话 那么opds_top因归位为0
 OperatorFunction = Str$(opds(0))
 Else
erroroccured:
 OperatorFunction = "表达式出错"
 End If
 
End Function

'运算符进栈
Private Function push_ops(ch As String) As Boolean

If ops_top < 20 Then
On Error GoTo ERROR1
  ops_top = ops_top + 1
  ops(ops_top) = ch
  push_ops = True
Else
ERROR1:
 push_ops = False
End If

End Function
'运算符出栈
Private Function pop_ops() As String

If ops_top > -1 Then
pop_ops = ops(ops_top)
ops_top = ops_top - 1
End If

End Function
'数值进栈
Private Function push_opds(ch As String) As Boolean
 If opds_top < 20 Then
  On Error GoTo ERROR2
   opds_top = opds_top + 1
   opds(opds_top) = CSng(ch)
   push_opds = True
Else
ERROR2:
  push_opds = False
End If

End Function
'数值出栈
Private Function pop_opds() As Single
 
 If opds_top > -1 Then
   pop_opds = opds(opds_top)
   opds_top = opds_top - 1
 End If
 
End Function

Function relation(sym1 As String, sym2 As String) As String
 Dim ch1(1) As String
 Dim ind(1) As Integer
 Dim re(6, 6) As String
 
 re(0, 0) = ">": re(0, 1) = ">": re(0, 2) = "<": re(0, 3) = "<": re(0, 4) = "<": re(0, 5) = ">": re(0, 6) = ">"
 re(1, 0) = ">": re(1, 1) = ">": re(1, 2) = "<": re(1, 3) = "<": re(1, 4) = "<": re(1, 5) = ">": re(1, 6) = ">"
 re(2, 0) = ">": re(2, 1) = ">": re(2, 2) = ">": re(2, 3) = ">": re(2, 4) = "<": re(2, 5) = ">": re(2, 6) = ">"
 re(3, 0) = ">": re(3, 1) = ">": re(3, 2) = ">": re(3, 3) = ">": re(3, 4) = "<": re(3, 5) = ">": re(3, 6) = ">"
 re(4, 0) = "<": re(4, 1) = "<": re(4, 2) = "<": re(4, 3) = "<": re(4, 4) = "<": re(4, 5) = "=": re(4, 6) = ""
 re(5, 0) = ">": re(5, 1) = ">": re(5, 2) = ">": re(5, 3) = ">": re(5, 4) = "": re(5, 5) = ">": re(5, 6) = ">"
 re(6, 0) = "<": re(6, 1) = "<": re(6, 2) = "<": re(6, 3) = "<": re(6, 4) = "<": re(6, 5) = "": re(6, 6) = "="

 ch1(0) = sym1
 ch1(1) = sym2
 For i = 0 To 1
   Select Case ch1(i)
   Case "+"
   ind(i) = 0
   Case "-"
   ind(i) = 1
   Case "*"
   ind(i) = 2
   Case "/"
   ind(i) = 3
   Case "("
   ind(i) = 4
   Case ")"
   ind(i) = 5
   Case "#"
   ind(i) = 6
   Case Else
   relation = ""
   Exit Function
  End Select
 Next i
  
  relation = re(ind(0), ind(1))
End Function
Function operate(a As Single, sym As String, b As Single) As Single
 Dim re As Single
 Select Case sym
        Case "+"
          re = a + b
        Case "-"
          re = a - b
        Case "*"
          re = a * b
        Case "/"
          re = a / b
 End Select
 operate = re
End Function



'本子函数用来获取要用户算数表达式中的各数字及各种运算符
Function getch() As String
Dim c As String
c = Left$(strtext, 1)
If c = "0" Then  '去掉像08中的0
strtext = Right$(strtext, Len(strtext) - 1)
c = Left$(strtext, 1)
End If
If IsNumeric(c) = True Then '返回数值部份
  c = Val(strtext)
  strtext = Right$(strtext, Len(strtext) - Len(CStr(c)))
  getch = CStr(c)
  Exit Function
Else                          '返回运算符 如＋、－、/、＊、（、)
   If Len(strtext) > 0 Then strtext = Right$(strtext, Len(strtext) - 1)
   getch = c
End If
End Function