VB字符串表达式计算函数.

      这是一个VB6.0的字符串表达式计算函数.

 

1. Private Function EvaluateExpr(ByVal expr As String) As Single
2.        Const PREC_NONE = 11
3.        Const PREC_UNARY = 10
4.        Const PREC_POWER = 9
5.        Const PREC_TIMES = 8
6.        Const PREC_DIV = 7
7.        Const PREC_INT_DIV = 6
8.        Const PREC_MOD = 5
9.        Const PREC_PLUS = 4
11.        Dim is_unary   As Boolean
12.        Dim next_unary   As Boolean
13.        Dim parens   As Integer
14.        Dim pos   As Integer
15.        Dim expr_len   As Integer
16.        Dim ch   As String
17.        Dim lexpr   As String
18.        Dim rexpr   As String
19.        Dim value   As String
20.        Dim status   As Long
21.        Dim best_pos   As Integer
22.        Dim best_prec   As Integer
24.        '  Remove  leading  and  trailing  blanks.
25.        expr = Trim$(expr)
26.        expr_len = Len(expr)
27.        If expr_len = 0 Then Exit Function
29.        '  If  we  find  +  or  -  now,  it  is  a  unary  operator.
30.        is_unary = True
32.        '  So  far  we  have  nothing.
33.        best_prec = PREC_NONE
35.        '  Find  the  operator  with  the  lowest  precedence.
36.        '  Look  for  places  where  there  are  no  open
37.        '  parentheses.
38.        For pos = 1 To expr_len
39.                '  Examine  the  next  character.
40.                ch = Mid$(expr, pos, 1)
42.                '  Assume  we  will  not  find  an  operator.  In
43.                '  that  case  the  next  operator  will  not
44.                '  be  unary.
45.                next_unary = False
47.                If ch = "  " Then
48.                        '  Just  skip  spaces.
49.                        next_unary = is_unary
50.                ElseIf ch = "(" Then
51.                        '  Increase  the  open  parentheses  count.
52.                        parens = parens + 1
54.                        '  An  operator  after  "("  is  unary.
55.                        next_unary = True
56.                ElseIf ch = ")" Then
57.                        '  Decrease  the  open  parentheses  count.
58.                        parens = parens - 1
60.                        '  An  operator  after  ")"  is  not  unary.
61.                        next_unary = False
63.                        '  If  parens  <  0,  too  many  ')'s.
64.                        If parens < 0 Then
65.                                Err.Raise vbObjectError + 1001, _
66.                                        "EvaluateExpr", _
67.                                        "Too  many  )s  in  '" & _
68.                                        expr & "'"
69.                        End If
70.                ElseIf parens = 0 Then
71.                        '  See  if  this  is  an  operator.
72.                        If ch = "^" Or ch = "*" Or _
73.                              ch = "/" Or ch = "/" Or _
74.                              ch = "%" Or ch = "+" Or _
75.                              ch = "-" _
76.                        Then
77.                                '  An  operator  after  an  operator
78.                                '  is  unary.
79.                                next_unary = True
80.                                  
81.                                Select Case ch
82.                                        Case "^"
83.                                                If best_prec >= PREC_POWER Then
84.                                                        best_prec = PREC_POWER
85.                                                        best_pos = pos
86.                                                End If
87.                                          
88.                                        Case "*", "/"
89.                                                If best_prec >= PREC_TIMES Then
90.                                                        best_prec = PREC_TIMES
91.                                                        best_pos = pos
92.                                                End If
93.                                          
94.                                        Case "/"
95.                                                If best_prec >= PREC_INT_DIV Then
96.                                                        best_prec = PREC_INT_DIV
97.                                                        best_pos = pos
98.                                                End If
99.                                          
100.                                        Case "%"
101.                                                If best_prec >= PREC_MOD Then
102.                                                        best_prec = PREC_MOD
103.                                                        best_pos = pos
104.                                                End If
105.                                          
106.                                        Case "+", "-"
107.                                                '  Ignore  unary  operators
108.                                                '  for  now.
109.                                                If (Not is_unary) And _
110.                                                        best_prec >= PREC_PLUS _
111.                                                Then
112.                                                        best_prec = PREC_PLUS
113.                                                        best_pos = pos
114.                                                End If
115.                                End Select
116.                        End If
117.                End If
118.                is_unary = next_unary
119.        Next pos
120.          
121.        '  If  the  parentheses  count  is  not  zero,
122.        '  there's  a  ')'  missing.
123.        If parens <> 0 Then
124.                Err.Raise vbObjectError + 1002, _
125.                        "EvaluateExpr", "Missing  )  in  '" & _
126.                        expr & "'"
127.        End If
128.          
129.        '  Hopefully  we  have  the  operator.
130.        If best_prec < PREC_NONE Then
131.                lexpr = Left$(expr, best_pos - 1)
132.                rexpr = Right$(expr, expr_len - best_pos)
133.                Select Case Mid$(expr, best_pos, 1)
134.                        Case "^"
135.                                EvaluateExpr = _
136.                                        EvaluateExpr(lexpr) ^ _
137.                                        EvaluateExpr(rexpr)
138.                        Case "*"
139.                                EvaluateExpr = _
140.                                        EvaluateExpr(lexpr) * _
141.                                        EvaluateExpr(rexpr)
142.                        Case "/"
143.                                EvaluateExpr = _
144.                                        EvaluateExpr(lexpr) / _
145.                                        EvaluateExpr(rexpr)
146.                        Case "/"
147.                                EvaluateExpr = _
148.                                        EvaluateExpr(lexpr) / _
149.                                        EvaluateExpr(rexpr)
150.                        Case "%"
151.                                EvaluateExpr = _
152.                                        EvaluateExpr(lexpr) Mod _
153.                                        EvaluateExpr(rexpr)
154.                        Case "+"
155.                                EvaluateExpr = _
156.                                        EvaluateExpr(lexpr) + _
157.                                        EvaluateExpr(rexpr)
158.                        Case "-"
159.                                EvaluateExpr = _
160.                                        EvaluateExpr(lexpr) - _
161.                                        EvaluateExpr(rexpr)
162.                End Select
163.                Exit Function
164.        End If
165.          
166.        '  If  we  do  not  yet  have  an  operator,  there
167.        '  are  several  possibilities:
168.        '
169.        '  1.  expr  is  (expr2)  for  some  expr2.
170.        '  2.  expr  is  -expr2  or  +expr2  for  some  expr2.
171.        '  3.  expr  is  Fun(expr2)  for  a  function  Fun.
172.        '  4.  expr  is  a  primitive.
173.        '  5.  It's  a  literal  like  "3.14159".
174.          
175.        '  Look  for  (expr2).
176.        If Left$(expr, 1) = "(" And Right$(expr, 1) = ")" Then
177.                '  Remove  the  parentheses.
178.                EvaluateExpr = EvaluateExpr(Mid$(expr, 2, expr_len - 2))
179.                Exit Function
180.        End If
181.                  
182.        '  Look  for  -expr2.
183.        If Left$(expr, 1) = "-" Then
184.                EvaluateExpr = -EvaluateExpr( _
185.                        Right$(expr, expr_len - 1))
186.                Exit Function
187.        End If
188.          
189.        '  Look  for  +expr2.
190.        If Left$(expr, 1) = "+" Then
191.                EvaluateExpr = EvaluateExpr( _
192.                        Right$(expr, expr_len - 1))
193.                Exit Function
194.        End If
195.          
196.        '  Look  for  Fun(expr2).
197.        If expr_len > 5 And Right$(expr, 1) = ")" Then
198.                lexpr = LCase$(Left$(expr, 4))
199.                rexpr = Mid$(expr, 5, expr_len - 5)
200.                Select Case lexpr
201.                        Case "sin("
202.                                EvaluateExpr = Sin(EvaluateExpr(rexpr))
203.                                Exit Function
204.                        Case "cos("
205.                                EvaluateExpr = Cos(EvaluateExpr(rexpr))
206.                                Exit Function
207.                        Case "tan("
208.                                EvaluateExpr = Tan(EvaluateExpr(rexpr))
209.                                Exit Function
210.                        Case "sqr("
211.                                EvaluateExpr = Sqr(EvaluateExpr(rexpr))
212.                                Exit Function
213.                End Select
214.        End If
215.          
216.        On Error Resume Next
217.        EvaluateExpr = CSng(expr)
218.        status = Err.Number
219.        On Error GoTo 0
220.        If status <> 0 Then
221.                Err.Raise status, _
222.                        "EvaluateExpr", _
223.                        "Error  evaluating  '" & expr & _
224.                        "'  as  a  constant."
225.        End If
226. End Function