主题:谁有计算表达式的程序?
Hanan
[专家分:700] 发布于 2002-09-01 04:45:00
谁有计算表达式的程序?
回复列表 (共15个回复)
沙发
eerfaone [专家分:490] 发布于 2002-09-03 23:46:00
是要VB版还是要C版?
板凳
Hanan [专家分:700] 发布于 2002-09-04 00:38:00
VB版的,要源程序,谢谢.
3 楼
eerfaone [专家分:490] 发布于 2002-09-04 17:14:00
由于时间关系,我只给你编了一个简单的计算表达式的程序。
它只实现了四则混合运算,支持括号及小数点,没有实现函数运算功能,你可以在它的基础上完善。
使用方法:建立一个窗体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 楼
Hanan [专家分:700] 发布于 2002-09-04 23:27:00
万分感谢!
5 楼
Hanan [专家分:700] 发布于 2002-09-05 01:15:00
能介绍一下算法的思想吗?
有个小问题,两数相减1-2结果是1,2-1是-1。
1+2+((3+4))计算不了。
6 楼
eerfaone [专家分:490] 发布于 2002-09-05 23:13:00
算法的思想使用堆栈:
有两个堆栈,一个是运算符堆栈mstackop,另一个是数据堆栈mstacknum,算法流程是先从表达式字符串中读出数据或运算符(函数gettoken),如果是数据就压入数据堆栈;如果是运算符就与运算符堆栈栈顶运算符比较优先级(优先级通过数组mOsp和mIsp设定),如果栈外运算符外部优先级比栈内运算符内部优先级高则进栈,如果低或相等时则栈顶运算符出栈并执行该运算(运算得数据是数据堆栈栈顶两个数据),结果压入数据堆栈,如此循环至栈外运算符外部优先级比栈内运算符内部优先级高,如果遇到“)”则运算符出栈至遇上“)”为止;就这样循环读出数据或运算符并进行处理至表达式字符串结束。
你上面提的两个问题确实是这个程序的BUG,等我改好后再给你传一个。
7 楼
eerfaone [专家分:490] 发布于 2002-09-06 02:10:00
改正后的程序:
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 楼
Hanan [专家分:700] 发布于 2002-09-06 22:40:00
谢谢。
9 楼
liulsh [专家分:0] 发布于 2004-11-20 22:12:00
我编过从最简单的、到极其复杂的表达式计算器程序,(VB,VBA,VC都有)。不知你对那种感兴趣?
10 楼
ahighhand [专家分:1960] 发布于 2004-11-20 23:06:00
用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
我来回复