VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)
首页 - 经验之谈 - 识别常数的简单四则运算
发表评论(0)作者:, 平台:, 阅读:8127, 日期:2000-03-29
'识别常数的简单四则运算


VERSION 5.00

Begin VB.Form ExpressionForm

Caption = "Expression"

ClientHeight = 2310

ClientLeft = 1380

ClientTop = 2100

ClientWidth = 6615

LinkTopic = "Form1"

PaletteMode = 1 'UseZOrder

ScaleHeight = 2310

ScaleWidth = 6615

Begin VB.TextBox ExprText

Height = 285

Left = 0

TabIndex = 0

Top = 360

Width = 3615

End

Begin VB.CommandButton CmdEvaluate

Appearance = 0 'Flat

BackColor = &H80000005&

Caption = "Evaluate"

Default = -1 'True

Height = 495

Left = 1200

TabIndex = 11

Top = 960

Width = 1215

End

Begin VB.Frame Frame1

Appearance = 0 'Flat

Caption = "Primitives"

ForeColor = &H80000008&

Height = 2295

Left = 3720

TabIndex = 12

Top = 0

Width = 2895

Begin VB.TextBox NameText

Height = 285

Index = 0

Left = 240

TabIndex = 1

Top = 480

Width = 1215

End

Begin VB.TextBox ValueText

Height = 285

Index = 0

Left = 1560

TabIndex = 2

Top = 480

Width = 1215

End

Begin VB.TextBox NameText

Height = 285

Index = 1

Left = 240

TabIndex = 3

Top = 840

Width = 1215

End

Begin VB.TextBox ValueText

Height = 285

Index = 1

Left = 1560

TabIndex = 4

Top = 840

Width = 1215

End

Begin VB.TextBox NameText

Height = 285

Index = 2

Left = 240

TabIndex = 5

Top = 1200

Width = 1215

End

Begin VB.TextBox ValueText

Height = 285

Index = 2

Left = 1560

TabIndex = 6

Top = 1200

Width = 1215

End

Begin VB.TextBox NameText

Height = 285

Index = 3

Left = 240

TabIndex = 7

Top = 1560

Width = 1215

End

Begin VB.TextBox ValueText

Height = 285

Index = 3

Left = 1560

TabIndex = 8

Top = 1560

Width = 1215

End

Begin VB.TextBox NameText

Height = 285

Index = 4

Left = 240

TabIndex = 9

Top = 1920

Width = 1215

End

Begin VB.TextBox ValueText

Height = 285

Index = 4

Left = 1560

TabIndex = 10

Top = 1920

Width = 1215

End

Begin VB.Label Label1

Appearance = 0 'Flat

Caption = "Name"

ForeColor = &H80000008&

Height = 255

Index = 0

Left = 240

TabIndex = 14

Top = 240

Width = 615

End

Begin VB.Label Label1

Appearance = 0 'Flat

Caption = "Value"

ForeColor = &H80000008&

Height = 255

Index = 1

Left = 1560

TabIndex = 13

Top = 240

Width = 615

End

End

Begin VB.Label Label2

Appearance = 0 'Flat

Caption = "Expression"

ForeColor = &H80000008&

Height = 255

Left = 0

TabIndex = 17

Top = 0

Width = 975

End

Begin VB.Label Label3

Appearance = 0 'Flat

Caption = "Result"

ForeColor = &H80000008&

Height = 255

Left = 480

TabIndex = 16

Top = 1800

Width = 615

End

Begin VB.Label ResultLabel

BorderStyle = 1 'Fixed Single

Height = 255

Left = 1200

TabIndex = 15

Top = 1800

Width = 1215

End

End

Attribute VB_Name = "ExpressionForm"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Option Explicit


Dim Primitives As Collection


' ************************************************

' Evaluate the expression.

' ************************************************

Private Function EvaluateExpr(ByVal expr As String) As Single

Const PREC_NONE = 11

Const PREC_UNARY = 10 ' Not actually used.

Const PREC_POWER = 9

Const PREC_TIMES = 8

Const PREC_DIV = 7

Const PREC_INT_DIV = 6

Const PREC_MOD = 5

Const PREC_PLUS = 4


Dim is_unary As Boolean

Dim next_unary As Boolean

Dim parens As Integer

Dim pos As Integer

Dim expr_len As Integer

Dim ch As String

Dim lexpr As String

Dim rexpr As String

Dim value As String

Dim status As Long

Dim best_pos As Integer

Dim best_prec As Integer


' Remove leading and trailing blanks.

expr = Trim$(expr)

expr_len = Len(expr)

If expr_len = 0 Then Exit Function


' If we find + or - now, it is a unary operator.

is_unary = True


' So far we have nothing.

best_prec = PREC_NONE


' Find the operator with the lowest precedence.

' Look for places where there are no open

' parentheses.

For pos = 1 To expr_len

' Examine the next character.

ch = Mid$(expr, pos, 1)


' Assume we will not find an operator. In

' that case the next operator will not

' be unary.

next_unary = False


If ch = " " Then

' Just skip spaces.

next_unary = is_unary

ElseIf ch = "(" Then

' Increase the open parentheses count.

parens = parens + 1


' An operator after "(" is unary.

next_unary = True

ElseIf ch = ")" Then

' Decrease the open parentheses count.

parens = parens - 1


' An operator after ")" is unary.

next_unary = True


' If parens < 0, too many ')'s.

If parens < 0 Then

Err.Raise vbObjectError + 1001, _

"EvaluateExpr", _

"Too many )s in '" & _

expr & "'"

End If

ElseIf parens = 0 Then

' See if this is an operator.

If ch = "^" Or ch = "*" Or _

ch = "/" Or ch = "\" Or _

ch = "%" Or ch = "+" Or _

ch = "-" _

Then

' An operator after an operator

' is unary.

next_unary = True


Select Case ch

Case "^"

If best_prec >= PREC_POWER Then

best_prec = PREC_POWER

best_pos = pos

End If


Case "*", "/"

If best_prec >= PREC_TIMES Then

best_prec = PREC_TIMES

best_pos = pos

End If


Case "\"

If best_prec >= PREC_INT_DIV Then

best_prec = PREC_INT_DIV

best_pos = pos

End If


Case "%"

If best_prec >= PREC_MOD Then

best_prec = PREC_MOD

best_pos = pos

End If


Case "+", "-"

' Ignore unary operators

' for now.

If (Not is_unary) And _

best_prec >= PREC_PLUS _

Then

best_prec = PREC_PLUS

best_pos = pos

End If

End Select

End If

End If

is_unary = next_unary

Next pos


' If the parentheses count is not zero,

' there's a ')' missing.

If parens <> 0 Then

Err.Raise vbObjectError + 1002, _

"EvaluateExpr", "Missing ) in '" & _

expr & "'"

End If


' Hopefully we have the operator.

If best_prec < PREC_NONE Then

lexpr = Left$(expr, best_pos - 1)

rexpr = Right$(expr, expr_len - best_pos)

Select Case Mid$(expr, best_pos, 1)

Case "^"

EvaluateExpr = _

EvaluateExpr(lexpr) ^ _

EvaluateExpr(rexpr)

Case "*"

EvaluateExpr = _

EvaluateExpr(lexpr) * _

EvaluateExpr(rexpr)

Case "/"

EvaluateExpr = _

EvaluateExpr(lexpr) / _

EvaluateExpr(rexpr)

Case "\"

EvaluateExpr = _

EvaluateExpr(lexpr) \ _

EvaluateExpr(rexpr)

Case "%"

EvaluateExpr = _

EvaluateExpr(lexpr) Mod _

EvaluateExpr(rexpr)

Case "+"

EvaluateExpr = _

EvaluateExpr(lexpr) + _

EvaluateExpr(rexpr)

Case "-"

EvaluateExpr = _

EvaluateExpr(lexpr) - _

EvaluateExpr(rexpr)

End Select

Exit Function

End If


' If we do not yet have an operator, there

' are several possibilities:

'

' 1. expr is (expr2) for some expr2.

' 2. expr is -expr2 or +expr2 for some expr2.

' 3. expr is Fun(expr2) for a function Fun.

' 4. expr is a primitive.

' 5. It's a literal like "3.14159".


' Look for (expr2).

If Left$(expr, 1) = "(" And Right$(expr, 1) = ")" Then

' Remove the parentheses.

EvaluateExpr = EvaluateExpr(Mid$(expr, 2, expr_len - 2))

Exit Function

End If


' Look for -expr2.

If Left$(expr, 1) = "-" Then

EvaluateExpr = -EvaluateExpr( _

Right$(expr, expr_len - 1))

Exit Function

End If


' Look for +expr2.

If Left$(expr, 1) = "+" Then

EvaluateExpr = EvaluateExpr( _

Right$(expr, expr_len - 1))

Exit Function

End If


' Look for Fun(expr2).

If expr_len > 5 And Right$(expr, 1) = ")" Then

lexpr = LCase$(Left$(expr, 4))

rexpr = Mid$(expr, 5, expr_len - 5)

Select Case lexpr

Case "sin("

EvaluateExpr = Sin(EvaluateExpr(rexpr))

Exit Function

Case "cos("

EvaluateExpr = Cos(EvaluateExpr(rexpr))

Exit Function

Case "tan("

EvaluateExpr = Tan(EvaluateExpr(rexpr))

Exit Function

Case "sqr("

EvaluateExpr = Sqr(EvaluateExpr(rexpr))

Exit Function

End Select

End If


' See if it's a primitive.

On Error Resume Next

value = Primitives.Item(expr)

status = Err.Number

On Error GoTo 0

If status = 0 Then

EvaluateExpr = CSng(value)

Exit Function

End If


' It must be a literal like "2.71828".

On Error Resume Next

EvaluateExpr = CSng(expr)

status = Err.Number

On Error GoTo 0

If status <> 0 Then

Err.Raise status, _

"EvaluateExpr", _

"Error evaluating '" & expr & _

"' as a constant."

End If

End Function



' ************************************************

' Evaluate the expression entered by the user.

' ************************************************

Private Sub CmdEvaluate_Click()

Dim i As Integer

Dim name As String

Dim value As String

Dim expr As String

Dim rslt As Single

Dim pos As Integer


' Store the primitives.

Set Primitives = New Collection

For i = 0 To 4

name = Trim$(NameText(i).Text)

value = Trim$(ValueText(i).Text)

If name <> "" And value <> "" Then

Primitives.Add value, name

End If

Next i


' Get the expression.

expr = ExprText.Text


' Evaluate the expression.

ResultLabel.Caption = ""

On Error GoTo EvaluateError

rslt = EvaluateExpr(expr)

ResultLabel.Caption = Format$(rslt)

Exit Sub


EvaluateError:

Beep

MsgBox Err.Description

End Sub