回 帖 发 新 帖 刷新版面

主题:谁有计算表达式的程序?

谁有计算表达式的程序?

回复列表 (共15个回复)

沙发

是要VB版还是要C版?

板凳

VB版的,要源程序,谢谢.

3 楼

由于时间关系,我只给你编了一个简单的计算表达式的程序。
它只实现了四则混合运算,支持括号及小数点,没有实现函数运算功能,你可以在它的基础上完善。
使用方法:建立一个窗体Form1,添加一个文本框text1(输入表达式)和一个标签Label1(显示结果)及一个命令按钮(执行计算),再将下面的源程序加入窗体
ption Explicit

Private Type tOpTable
    op As String
    code As Integer
End Type
    
Const cMAXN = 1000
Const POW = 1
Const MUL = 2
Const DIV = 3
Const ADD = 4
Const SUB1 = 5
Const LP = 6
Const RP = 7
Const END1 = 8
Const Epsilon = 0.0000001
Const RADIX = 10

Private mStackOP(cMAXN) As Double           '运算符栈
Private mTopOP As Integer                   '运算符栈顶指针
Private mStackNum(cMAXN) As Double          '数据栈
Private mTopNum As Integer                  '数据栈顶指针
Private mOpchTbl(7) As tOpTable             '运算符表
Private mOsp(7) As Integer                  '外部优先级表
Private mIsp(5) As Integer                  '内部优先级表
Private mIsError As Boolean
Private mFormula As String
Private mIndex As Integer

Private Function Push(vStack() As Double, ByVal vMaxN As Integer, vToppt As Integer, ByVal x As Double) As Integer
    If vToppt >= vMaxN Then
        Push = 1
    Else
        vStack(vToppt) = x
        vToppt = vToppt + 1
        Push = 0
    End If
End Function

Private Function Pop(vStack() As Double, vToppt As Integer, vCp As Double) As Integer
    If vToppt = 0 Then
        Pop = 1
    Else
        vToppt = vToppt - 1
        vCp = vStack(vToppt)
        Pop = 0
    End If
End Function

Private Sub InitTbl()
    mOpchTbl(0).op = "*"
    mOpchTbl(0).code = 2
    mOpchTbl(1).op = "/"
    mOpchTbl(1).code = 3
    mOpchTbl(2).op = "+"
    mOpchTbl(2).code = 4
    mOpchTbl(3).op = "-"
    mOpchTbl(3).code = 5
    mOpchTbl(4).op = "("
    mOpchTbl(4).code = 6
    mOpchTbl(5).op = ")"
    mOpchTbl(5).code = 7
    mOpchTbl(6).op = "^"
    mOpchTbl(6).code = 1
    mOpchTbl(6).op = Chr(13)
    mOpchTbl(6).code = 8
    mOsp(0) = 5
    mOsp(1) = 3
    mOsp(2) = 3
    mOsp(3) = 2
    mOsp(4) = 2
    mOsp(5) = 5
    mOsp(6) = 1
    mOsp(7) = 1
    mIsp(0) = 4
    mIsp(1) = 3
    mIsp(2) = 3
    mIsp(3) = 2
    mIsp(4) = 2
    mIsp(5) = 0
End Sub

Private Sub synError(ByVal n As Integer)
    Select Case n
        Case 0:
            MsgBox "表达式句法错"
        Case 1:
            MsgBox "除零出错"
    End Select
    mIsError = True
End Sub

Private Function eval(ByVal vtag As Integer, ByVal vleft As Double, ByVal vright As Double) As Double
    Dim i As Integer
    Dim result As Double
    Select Case vtag
        Case POW:
            result = vleft
            i = 1
            While i < vright
                result = result * vleft
                i = i + 1
            Wend
            eval = result
        Case ADD:
            eval = vleft + vright
        Case SUB1:
            eval = vleft - vright
        Case MUL:
            eval = vleft * vright
        Case DIV:
            If Abs(vright) <= Epsilon Then
                synError 1
                Exit Function
            End If
            eval = vleft / vright
        Case Else:
            synError 0
    End Select
End Function

Private Function getToken(vNump As Double) As Integer
    Dim vRadix As Double
    Dim vNum As Double
    Dim i As Integer
    Dim vTemp As String
    
    vTemp = Mid(mFormula, mIndex, 1)
    Do While vTemp = " " Or vTemp = Chr(9)
        mIndex = mIndex + 1
        vTemp = Mid(mFormula, mIndex, 1)
    Loop
    If vTemp < "0" Or vTemp > "9" Then
        For i = 0 To 6
            If mOpchTbl(i).op = vTemp Then Exit For
        Next i
        If i > 6 Then
            synError (1)
        Else
            getToken = mOpchTbl(i).code
            mIndex = mIndex + 1
        End If
        Exit Function
    End If
    vNum = 0
    While vTemp >= "0" And vTemp <= "9"
        vNum = RADIX * vNum + Val(vTemp)
        mIndex = mIndex + 1
        vTemp = Mid(mFormula, mIndex, 1)
    Wend
    If vTemp = "." Then
        vRadix = 1# / RADIX
        mIndex = mIndex + 1
        vTemp = Mid(mFormula, mIndex, 1)
        While vTemp >= "0" And vTemp <= "9"
            vNum = vNum + Val(vTemp) * vRadix
            vRadix = vRadix / RADIX
            mIndex = mIndex + 1
            vTemp = Mid(mFormula, mIndex, 1)
        Wend
    End If
    vNump = vNum
End Function

Private Sub calFormula()
    Dim vNum As Double, vDop As Double, vOperand1 As Double, vOperand2 As Double, vRes As Double
    Dim vType As Integer, Vop As Integer, vLen As Integer
    mTopOP = 0
    mTopNum = 0
    mFormula = Text1.Text
    mFormula = Trim(mFormula) + Chr(13)
    mIndex = 1
    vLen = Len(mFormula)
    mIsError = False
    While mIndex <= vLen And Not mIsError
        vType = getToken(vNum)
        If vType = 0 Then
            Push mStackNum, cMAXN, mTopNum, vNum
        ElseIf mTopOP = 0 Then
            Push mStackOP, cMAXN, mTopOP, vType
        Else
            If mOsp(vType - 1) > mIsp(CInt(mStackOP(mTopOP - 1)) - 1) Then
                Push mStackOP, cMAXN, mTopOP, vType
            Else
                Do While mOsp(vType - 1) <= mIsp(CInt(mStackOP(mTopOP - 1)) - 1) And mStackOP(mTopOP - 1) <= 5
                    If Pop(mStackOP, mTopOP, vDop) <> 0 Then synError 0
                    Vop = CInt(vDop)
                    If Pop(mStackNum, mTopNum, vOperand1) <> 0 Then synError 0
                    If Pop(mStackNum, mTopNum, vOperand2) <> 0 Then synError 0
                    vRes = eval(Vop, vOperand1, vOperand2)
                    Push mStackNum, cMAXN, mTopNum, vRes
                    If mTopOP = 0 Then Exit Do
                Loop
                If vType = RP Then
                    Do
                        If Pop(mStackOP, mTopOP, vDop) <> 0 Then synError 0
                    Loop While CInt(vDop) <> LP
                Else
                    Push mStackOP, cMAXN, mTopOP, vType
                End If
            End If
        End If
    Wend
    If Pop(mStackNum, mTopNum, vOperand1) <> 0 Then synError 0
    Label1.Caption = Str(vOperand1)
End Sub

Private Sub Command1_Click()
    calFormula
End Sub

Private Sub Form_Load()
    InitTbl
End Sub

4 楼

万分感谢!

5 楼

能介绍一下算法的思想吗?
有个小问题,两数相减1-2结果是1,2-1是-1。
1+2+((3+4))计算不了。

6 楼

算法的思想使用堆栈:
  有两个堆栈,一个是运算符堆栈mstackop,另一个是数据堆栈mstacknum,算法流程是先从表达式字符串中读出数据或运算符(函数gettoken),如果是数据就压入数据堆栈;如果是运算符就与运算符堆栈栈顶运算符比较优先级(优先级通过数组mOsp和mIsp设定),如果栈外运算符外部优先级比栈内运算符内部优先级高则进栈,如果低或相等时则栈顶运算符出栈并执行该运算(运算得数据是数据堆栈栈顶两个数据),结果压入数据堆栈,如此循环至栈外运算符外部优先级比栈内运算符内部优先级高,如果遇到“)”则运算符出栈至遇上“)”为止;就这样循环读出数据或运算符并进行处理至表达式字符串结束。
你上面提的两个问题确实是这个程序的BUG,等我改好后再给你传一个。

7 楼

改正后的程序:
Option Explicit

Private Type tOpTable
    op As String
    code As Integer
End Type
    
Const cMAXN = 1000
Const POW = 1
Const MUL = 2
Const DIV = 3
Const ADD = 4
Const SUB1 = 5
Const LP = 6
Const RP = 7
Const END1 = 8
Const Epsilon = 0.0000001
Const RADIX = 10

Private mStackOP(cMAXN) As Double           '运算符栈
Private mTopOP As Integer                   '运算符栈顶指针
Private mStackNum(cMAXN) As Double          '数据栈
Private mTopNum As Integer                  '数据栈顶指针
Private mOpchTbl(7) As tOpTable             '运算符表
Private mOsp(7) As Integer                  '外部优先级表
Private mIsp(5) As Integer                  '内部优先级表
Private mIsError As Boolean
Private mFormula As String
Private mIndex As Integer

Private Function Push(vStack() As Double, ByVal vMaxN As Integer, vToppt As Integer, ByVal x As Double) As Integer
    If vToppt >= vMaxN Then
        Push = 1
    Else
        vStack(vToppt) = x
        vToppt = vToppt + 1
        Push = 0
    End If
End Function

Private Function Pop(vStack() As Double, vToppt As Integer, vCp As Double) As Integer
    If vToppt = 0 Then
        Pop = 1
    Else
        vToppt = vToppt - 1
        vCp = vStack(vToppt)
        Pop = 0
    End If
End Function

Private Sub InitTbl()
    mOpchTbl(0).op = "*"
    mOpchTbl(0).code = MUL
    mOpchTbl(1).op = "/"
    mOpchTbl(1).code = DIV
    mOpchTbl(2).op = "+"
    mOpchTbl(2).code = ADD
    mOpchTbl(3).op = "-"
    mOpchTbl(3).code = SUB1
    mOpchTbl(4).op = "("
    mOpchTbl(4).code = LP
    mOpchTbl(5).op = ")"
    mOpchTbl(5).code = RP
    mOpchTbl(6).op = "^"
    mOpchTbl(6).code = POW
    mOpchTbl(7).op = Chr(13)
    mOpchTbl(7).code = END1
    
    mOsp(0) = 5             'POW
    mOsp(1) = 3             'MUL
    mOsp(2) = 3             'DIV
    mOsp(3) = 2             'ADD
    mOsp(4) = 2             'SUB1
    mOsp(5) = 5             'LP
    mOsp(6) = 1             'RP
    mOsp(7) = 1             'END1
    
    mIsp(0) = 4             'POW
    mIsp(1) = 3             'MUL
    mIsp(2) = 3             'DIV
    mIsp(3) = 2             'ADD
    mIsp(4) = 2             'SUB1
    mIsp(5) = 1             'LP
End Sub

Private Sub synError(ByVal n As Integer)
    Select Case n
        Case 0:
            MsgBox "表达式句法错"
        Case 1:
            MsgBox "除零出错"
    End Select
    mIsError = True
End Sub

Private Function eval(ByVal vtag As Integer, ByVal vleft As Double, ByVal vright As Double) As Double
    Dim i As Integer
    Dim result As Double
    Select Case vtag
        Case POW:
            result = vleft
            i = 1
            While i < vright
                result = result * vleft
                i = i + 1
            Wend
            eval = result
        Case ADD:
            eval = vleft + vright
        Case SUB1:
            eval = vleft - vright
        Case MUL:
            eval = vleft * vright
        Case DIV:
            If Abs(vright) <= Epsilon Then
                synError 1
                Exit Function
            End If
            eval = vleft / vright
        Case Else:
            synError 0
    End Select
End Function

Private Function getToken(vNump As Double) As Integer
    Dim vRadix As Double
    Dim vNum As Double
    Dim i As Integer
    Dim vTemp As String
    
    vTemp = Mid(mFormula, mIndex, 1)
    Do While vTemp = " " Or vTemp = Chr(9)
        mIndex = mIndex + 1
        vTemp = Mid(mFormula, mIndex, 1)
    Loop
    If vTemp < "0" Or vTemp > "9" Then
        For i = 0 To 6
            If mOpchTbl(i).op = vTemp Then Exit For
        Next i
        If i > 7 Then
            synError 0
        Else
            getToken = mOpchTbl(i).code
            mIndex = mIndex + 1
        End If
        Exit Function
    End If
    vNum = 0
    While vTemp >= "0" And vTemp <= "9"
        vNum = RADIX * vNum + Val(vTemp)
        mIndex = mIndex + 1
        vTemp = Mid(mFormula, mIndex, 1)
    Wend
    If vTemp = "." Then
        vRadix = 1# / RADIX
        mIndex = mIndex + 1
        vTemp = Mid(mFormula, mIndex, 1)
        While vTemp >= "0" And vTemp <= "9"
            vNum = vNum + Val(vTemp) * vRadix
            vRadix = vRadix / RADIX
            mIndex = mIndex + 1
            vTemp = Mid(mFormula, mIndex, 1)
        Wend
    End If
    vNump = vNum
End Function

Private Sub calFormula()
    Dim vNum As Double, vDop As Double, vOperand1 As Double, vOperand2 As Double, vRes As Double
    Dim vType As Integer, Vop As Integer, vLen As Integer
    mTopOP = 0
    mTopNum = 0
    mFormula = Text1.Text
    mFormula = Trim(mFormula) + Chr(13)
    mIndex = 1
    vLen = Len(mFormula)
    mIsError = False
    While mIndex <= vLen And Not mIsError
        vType = getToken(vNum)
        If vType = 0 Then
            Push mStackNum, cMAXN, mTopNum, vNum
        ElseIf mTopOP = 0 Then
            Push mStackOP, cMAXN, mTopOP, vType
        Else
            If mOsp(vType - 1) > mIsp(CInt(mStackOP(mTopOP - 1)) - 1) Then
                Push mStackOP, cMAXN, mTopOP, vType
            Else
                Do While mOsp(vType - 1) <= mIsp(CInt(mStackOP(mTopOP - 1)) - 1) And mStackOP(mTopOP - 1) <= 5
                    If Pop(mStackOP, mTopOP, vDop) <> 0 Then synError 0
                    Vop = CInt(vDop)
                    If Pop(mStackNum, mTopNum, vOperand2) <> 0 Then synError 0
                    If Pop(mStackNum, mTopNum, vOperand1) <> 0 Then synError 0
                    vRes = eval(Vop, vOperand1, vOperand2)
                    Push mStackNum, cMAXN, mTopNum, vRes
                    If mTopOP = 0 Then Exit Do
                Loop
                If vType = RP Then
                    Do
                        If Pop(mStackOP, mTopOP, vDop) <> 0 Then synError 0
                    Loop While CInt(vDop) <> LP
                Else
                    Push mStackOP, cMAXN, mTopOP, vType
                End If
            End If
        End If
    Wend
    If Pop(mStackNum, mTopNum, vOperand1) <> 0 Then synError 0
    If Not mIsError Then
        Label1.Caption = Str(vOperand1)
    End If
End Sub

Private Sub Command1_Click()
    calFormula
End Sub

Private Sub Form_Load()
    InitTbl
End Sub

8 楼

谢谢。

9 楼

我编过从最简单的、到极其复杂的表达式计算器程序,(VB,VBA,VC都有)。不知你对那种感兴趣?

10 楼

用ScriptControl可以算更复杂的表达式:

Private Sub Command1_Click()
Dim X As String
X = "Exp(Sqr(1+2-3*4/5)^COS(4*ATN(1)/3))"
MsgBox X & "=" & RESULT(X)
End Sub

Function RESULT(ByVal X As String) As Double
Dim OBJ As Object
Set OBJ = CreateObject("MSScriptControl.ScriptControl")
  OBJ.Language = "vbscript"
RESULT = OBJ.Eval(X)
Set OBJ = Nothing
End Function

我来回复

您尚未登录,请登录后再回复。点此登录或注册