用户登陆
站点日历
站点统计
最新评论
vb 表达试计算 [ 日期：2007-04-06 ] [ 来自：vb 表达试计算
Private Sub Command1_Click()
Dim test As String
test = "1.5*(2.5+3.5)-(5.5-1)/3"
Set scr = CreateObject("MSScriptControl.ScriptControl")
scr.Language = "vbscript"
MsgBox test & "=" & scr.Eval(test)
End Sub
Dim test As String
test = "1.5*(2.5+3.5)-(5.5-1)/3"
Set scr = CreateObject("MSScriptControl.ScriptControl")
scr.Language = "vbscript"
MsgBox test & "=" & scr.Eval(test)
End Sub
另一种方法更简单，用WebBrowser控件
WebBrowser1.Navigate "javascript:" & "1.5*(2.5+3.5)-(5.5-1)/3"
msgbox WebBrowser1.Document.body.innerHTML
WebBrowser1.Navigate "javascript:" & "1.5*(2.5+3.5)-(5.5-1)/3"
msgbox WebBrowser1.Document.body.innerHTML
Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long ' API
Private Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function
Private Function result(ByVal x As String) As Single '计算表达式的结果
ExecuteLine "dim x as single"
ExecuteLine "x= " & x
ExecuteLine "clipboard.settext x" '发送到剪切板
result = Clipboard.GetText '从剪切板获取
Clipboard.Clear '清空剪切板
End Function
Private Sub Command1_Click()
Dim test As String
test = "1.5*(2.5+3.5)-(5.5-1)/3"
MsgBox test & "=" & result(test)
End Sub
Private Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function
Private Function result(ByVal x As String) As Single '计算表达式的结果
ExecuteLine "dim x as single"
ExecuteLine "x= " & x
ExecuteLine "clipboard.settext x" '发送到剪切板
result = Clipboard.GetText '从剪切板获取
Clipboard.Clear '清空剪切板
End Function
Private Sub Command1_Click()
Dim test As String
test = "1.5*(2.5+3.5)-(5.5-1)/3"
MsgBox test & "=" & result(test)
End Sub
再给你一个已用在商业软件中的代码
Private Function EvaluateExpr(ByVal expr As String) As Single
'--------------------------------------------------------------------------
'功能:
' 字符串表达式的计算
'参数:
' [expr]...........................字符串表达式
'返回值:
' [EvaluateExpr]...................计算后的值
'--------------------------------------------------------------------------
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
' 删除首尾空格及有效性校验
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 not unary.
next_unary = False
' 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.
' best_prec是最高的运算符
Dim dblTemp1 As Double, dblTemp2 As Double
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 "/"
dblTemp1 = EvaluateExpr(rexpr)
dblTemp2 = EvaluateExpr(lexpr)
If dblTemp1 = 0 Then
EvaluateExpr = 0
Else
EvaluateExpr = dblTemp2 / dblTemp1
End If
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
Private Function EvaluateExpr(ByVal expr As String) As Single
'--------------------------------------------------------------------------
'功能:
' 字符串表达式的计算
'参数:
' [expr]...........................字符串表达式
'返回值:
' [EvaluateExpr]...................计算后的值
'--------------------------------------------------------------------------
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
' 删除首尾空格及有效性校验
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 not unary.
next_unary = False
' 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.
' best_prec是最高的运算符
Dim dblTemp1 As Double, dblTemp2 As Double
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 "/"
dblTemp1 = EvaluateExpr(rexpr)
dblTemp2 = EvaluateExpr(lexpr)
If dblTemp1 = 0 Then
EvaluateExpr = 0
Else
EvaluateExpr = dblTemp2 / dblTemp1
End If
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
'在工程中添加“Microsoft Script Control1.0”控件，然后试试下面的代码
Private Sub Command1_Click()
MsgBox Me.ScriptControl1.Eval("1.5*(2.5+3.5)-(5.5-1)/3")
End Sub
Private Sub Command1_Click()
MsgBox Me.ScriptControl1.Eval("1.5*(2.5+3.5)-(5.5-1)/3")
End Sub
在工程中添加“Microsoft Script Control1.0”控件，然后试试下面的代码
Private Sub Command1_Click()
With Me.ScriptControl1
.AddCode "dim a,b"
.AddCode "b=1"
.AddCode "a=b+10"
.AddCode "Msgbox a"
End With
End Sub
Private Sub Command1_Click()
With Me.ScriptControl1
.AddCode "dim a,b"
.AddCode "b=1"
.AddCode "a=b+10"
.AddCode "Msgbox a"
End With
End Sub
Option Explicit
Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long
Public Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function
Private Sub Command1_Click()
ExecuteLine "Dim X As Long, Y As Long"
ExecuteLine "x = 2"
ExecuteLine "y = 3"
ExecuteLine "msgbox " & Text1.Text
End Sub
Private Sub Form_Load()
Text1.Text = "x+y"
End Sub
Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long
Public Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function
Private Sub Command1_Click()
ExecuteLine "Dim X As Long, Y As Long"
ExecuteLine "x = 2"
ExecuteLine "y = 3"
ExecuteLine "msgbox " & Text1.Text
End Sub
Private Sub Form_Load()
Text1.Text = "x+y"
End Sub
实例：（转自雪源在线 www.play78.com).
点击下载此文件[本日志由 田草 于 2007-04-17 09:14 PM 编辑]
|
|
暂时没有评论
| 发表评论 - 不要忘了输入验证码哦！ |