| 发表于：2007-12-30 01:09:53 楼主 |
以下代码取自:
laviewpbt的专栏
http://blog.csdn.net/laviewpbt/archive/2007/09/29/1806217.aspx
我做了部分改动主要想分解表达式，如:
"12\x1+x3+exp（sin（3,4),4,x1,x2)+x2"
目的分解成:（这里假设 sin 和 exp 是个多参数自定义函数)
变量1 = 12 \ x1
变量2 = 变量1 + x3
变量3 = sin 3,4
变量4 = exp 变量3,4,x1,x2
变量5 = 变量2 + 变量4
变量6 = 变量5 + x2
现在问题是我不知道如何处理逗号，下面是实际分解结果:
变量1 = 12 \ x1
变量2 = 变量1 + x3
变量3 = exp sin（3,4),4,x1,x2
变量4 = 变量2 + 变量3
变量5 = 变量4 + x2
'=======================代码===========================
'需要 text1 command1
'定义的各算子的优先级
private const prec_none = 11 '
private const prec_unary = 10 '实际中没有用到
private const prec_power = 9 '^
private const prec_times = 8 '*
private const prec_div = 7 '/
private const prec_int_div = 6 '\
private const prec_mod = 5 'mod
private const prec_plus = 4 '+
private m_变量 as long
private function eval（byval expression as string, paramarray data（) as variant) as string
dim is_unary as boolean
dim next_unary as boolean
dim brackets as integer
dim pos as integer
dim expression_len as integer
dim char as string
dim leftexpression as string
dim rightexpression as string
dim value as string
dim status as long
dim best_pos as integer
dim best_prec as integer
dim temp1 as double
dim temp2 as double
dim v as variant
static i as long
if i = 0 then '因为是递归，所以要防止重复做无用功
expression = lcase（trim（expression)) '删除首尾空格并把字符转换成小写
for each v in data
'expression = replace（expression, "x" & i, v)
i = i + 1
next
end if
expression_len = len（expression) '计算字符串的长度，一定要放在上面代码的下部
if expression_len = 0 then exit function
is_unary = true '如果有+或-,则是单元运算符
best_prec = prec_none '到目前为止我们什么也没得到
for pos = 1 to expression_len
char = mid（expression, pos, 1) '检查下一个字符
next_unary = false
if char = " " then '跳过空格
next_unary = is_unary
elseif char = "（" then
brackets = brackets + 1 '增加括号的个数
next_unary = true
elseif char = ")" then
brackets = brackets - 1 '减少括号的个数
next_unary = false
if brackets < 0 then '左右括号的个数不配套
err.raise vbobjecterror + 1001, "错误", "表达式中左右括号的个数不配套"
end if
elseif brackets = 0 then
if char = "^" or char = "*" or char = "/" or char = "\" or char = "%" or char = "+" or char = "-" then
next_unary = true
select case char
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 "+", "-"
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
if brackets <> 0 then
err.raise vbobjecterror + 1002, "错误", "表达式中丢失一个 )"
end if
if best_prec < prec_none then
leftexpression = left（expression, best_pos - 1)
rightexpression = right（expression, expression_len - best_pos)
select case mid（expression, best_pos, 1)
case "^"
eval = 方根（eval（leftexpression), eval（rightexpression))
case "*"
eval = 乘法（eval（leftexpression), eval（rightexpression))
case "/"
eval = 除法（eval（leftexpression), eval（rightexpression))
'temp1 = eval（rightexpression)
'temp2 = eval（leftexpression)
'if temp1 = 0 then
' eval = 0
'else
' eval = temp2 / temp1
'end if
case "\"
eval = 整除（eval（leftexpression), eval（rightexpression))
case "%"
eval = 取模（eval（leftexpression), eval（rightexpression))
case "+"
eval = 加法（eval（leftexpression), eval（rightexpression))
case "-"
eval = 减法（eval（leftexpression), eval（rightexpression))
end select
exit function
end if
if left（expression, 1) = "（" and right（expression, 1) = ")" then
eval = eval（mid（expression, 2, expression_len - 2))
exit function
end if
if left（expression, 1) = "-" then
eval = -eval（right（expression, expression_len - 1))
exit function
end if
if left（expression, 1) = "+" then
eval = eval（right（expression, expression_len - 1))
exit function
end if
if expression_len > 5 and right（expression, 1) = ")" then
leftexpression = left（expression, 4)
rightexpression = mid（expression, 5, expression_len - 5)
'可根据逗号分割多个参数后代入，但是如果参数中仍包含有表达式如何?
select case leftexpression
case "sin（"
eval = sinn（eval（rightexpression))
case "cos（"
eval = cosn（eval（rightexpression))
case "tan（"
eval = tann（eval（rightexpression))
case "sqr（"
eval = sqrn（eval（rightexpression))
case "abs（"
eval = absn（eval（rightexpression))
case "exp（"
eval = expn（eval（rightexpression))
case "log（"
eval = logn（eval（rightexpression))
case "sgn（"
eval = sgnn（eval（rightexpression))
case "atn（"
eval = atnn（eval（rightexpression))
case "rnd（"
eval = rndn（eval（rightexpression))
end select
exit function
end if
on error goto errhandle:
eval = expression
exit function
errhandle:
err.raise vbobjecterror + 1003, "错误", "未知错误发生!"
end function
|
|
|
|
|
