表达式求值自定义函数突破255字符限制并兼容64位office

ggmmlol

本次更新，包含2个方面：1、提高效率；2、对0层括号的超长计算式，优化计算过程为分段处理。理论上可计算无限长度的无括号的四则运算式。

为提高函数运算效率，再次使用模块级全局变量，减少创建Html对象的次数，为修正“当不规范的计算式造成的‘运行错误’时，自动引用上一次函数结果的Bug”，设置模块内全局变量，比较与上一次结果的异同，如果相同，则强制上一次的结果为"空",然后再次计算，如果计算结果仍为空，判定为计算式不规范。此外，为减少DDL缓存，每2^10次函数计算后，清除原对象，重建html对象。

代码多了不少，但为了效率提升，还是很值得的。
jss.rar (42.9 KB, 下载次数: 131)

2019-10-26 21:37 上传

点击文件名下载附件

1. Option Explicit
   
2.     Private oDom As Object, oWin As Object, JSCode As String, Initialized As Boolean, beCleaned As Boolean, Partitioned As Boolean
   
3.     Private tms%, oReg As Object, lastValue, lastexp$, a, b
   
4. 
   
5. Sub Form_Load()
   
6.     Dim i%, tmp0$, tmp1$
   
7.     JSCode = "<script Language = JScript> function JS_EVAL(){return ExpValue}; var ExpValue; </script>"
   
8.     Set oDom = CreateObject("htmlfile")
   
9.     Set oWin = oDom.parentWindow
   
10.     oDom.write JSCode
    
11.     Set oReg = CreateObject("vbscript.regexp")
    
12.     oReg.Global = True
    
13.     tmp0 = "\blog\(、\blog10e\b、\bln(?=10\b|2\b)、＋、－、×、÷、（、）、(\d*\.?\d+|\w*\([^\(\)]*\)|\w+)\^(-?\d*\.?\d+|\w*\([^\(\)]*\)|\w+)、" & _
    
14.             "\btrunc\b、\bint\b、\b(sqrt|round|random|pow(er)?|pi(\(\))?|min|max|log(10e)?|ln(2|10)|exp|e|abs|a?tan2?|a?sin|a?cos)\b、" & _
    
15.             "\[[^\[\]]*\]|【[^【】]*】|(Math\.)(?=\1)|[\f\n\r\v\t]、power\b、Math.e\b、\.pi(\(\))?、\b(Math\.)?ln\(、(-\+*-|\+)+(?=[\+\-])|[\+\-]+$、--"
    
16. 
    
17.     tmp1 = "log10e*log(、Math.LOG10E、Math.LN、+、-、*、/、(、)、pow($1,$2)、" & _
    
18.             "parseInt、Math.floor、Math.$1、、pow、Math.E、.PI、Math.log(、、+"
    
19.     a = Split(tmp0, "、")
    
20.     b = Split(tmp1, "、")
    
21.     lastexp = Empty
    
22.     Initialized = True
    
23. End Sub
    
24. 
    
25. Private Function EXPCLEAN(ByVal exp$) As String
    
26.     Dim i As Integer
    
27.     If Not Initialized Then Form_Load
    
28.     If Not beCleaned Then
    
29.         exp = LCase(exp)
    
30.         With oReg
    
31.             For i = 0 To UBound(a)
    
32.                 .Pattern = a(i)
    
33.                 exp = .Replace(exp, b(i))
    
34.             Next
    
35.         End With
    
36.         beCleaned = True
    
37.     End If
    
38.     EXPCLEAN = exp
    
39. End Function
    
40. 
    
41. Function JSEVAL(ByVal s$) As Variant
    
42. Dim s1$, s2$, s3$
    
43.     s = EXPCLEAN(s)
    
44.     If Len(s) = 0 Then
    
45.         JSEVAL = ""
    
46.     Else
    
47.         If s = lastexp And Len(lastValue) Then JSEVAL = lastexp: Exit Function
    
48.         If tms >= 1023 Then ReSet
    
49.         If Not Partitioned Then
    
50.             oReg.Pattern = "^([\d\D]*?)(\b\w[^()]{2040,}\w\b(?!\.))[\d\D]*"
    
51.             If oReg.test(s) Then
    
52.                 Partitioned = True
    
53.                 oReg.Pattern = "^([\d\D]*?)(\b\w[^()]{60,2044}\w\b(?!\.))[\d\D]*"
    
54.                 Do While oReg.test(s)
    
55.                     s1 = oReg.Replace(s, "$1")
    
56.                     s2 = oReg.Replace(s, "$2")
    
57.                     s3 = Mid(s, Len(s1) + Len(s2) + 1)
    
58.                     s2 = JSEVAL(oReg.Replace(s, "$2"))
    
59.                     s = s1 & s2 & s3
    
60.                 Loop
    
61.                 Partitioned = False
    
62.             End If
    
63.         End If
    
64.         oDom.write "<script Language = JScript> ExpValue = " & s & "; </script>"
    
65.         JSEVAL = oWin.eval("JS_EVAL()")
    
66. 
    
67.         If JSEVAL = lastValue And IsNumeric(lastValue) Then
    
68.             oDom.write "<script Language = JScript> ExpValue = """"; </script>"
    
69.             JSEVAL = oWin.eval("JS_EVAL()")
    
70.             oDom.write "<script Language = JScript> ExpValue = " & s & "; </script>"
    
71.             JSEVAL = oWin.eval("JS_EVAL()")
    
72.         End If
    
73.         If Len(JSEVAL) = 0 Then JSEVAL = VBA.Error$(93)
    
74.     End If
    
75.     lastValue = JSEVAL: lastexp = s: beCleaned = Partitioned: tms = tms + 1
    
76. End Function
    
77. 
    
78. Sub ReSet()
    
79.     Set oWin = Nothing
    
80.     Set oDom = Nothing
    
81.     Initialized = False
    
82.     beCleaned = False
    
83.     Partitioned = False
    
84.     lastexp = Empty
    
85.     lastValue = 0
    
86.     tms = 0
    
87.     Form_Load
    
88. End Sub

复制代码

younger001

大神，好象还是有点问题，当出现非标计算式后每次按F9重算结果经常不一至

younger001

大神，出现这种类型的错误计算式会弹出下图

ggmmlol

lu6200 发表于 2018-12-23 00:54
楼主，能不能添加注释使用不区分中英文中括号，纯汉字不用添加括号的代码呢    非常感谢，这个对于外出或者 ...

我新发表了一个对工程量计算式求值的加载宏小工具，可以对任意格式的工作簿中的计算式进行快速计算（可“自动实时”或“手动批量”计算），并设置计算式中注释字符的字体格式。
且：
1、支持包含“代号”（以下划线接一个“汉、英”字符开始，后续可以接任意多个“汉、英、数”字符，如：_代号1、_DH1、_D栋3层C轴）
2、支持两种注释字符：a)“格式化”的注释字符，即成对方括号包含的任意字符,b)既不在成对方括号之中，又不能构成计算式有效字符(代号、函数名称、数值、运算符等)的任意字符。这种称为“灵活式”的注释字符。
3、支持全角的括号、花括号；全角的四则运算符；特殊常量圆周率的代号字符“π”
4、支持全部Excel工作表函数。
5、源码全公开，可以放心使用。也可供VBA自学人员参考。

tangteng822

这种函数的计算过程，好像没有办法计算

shenjianrong163

好贴，收藏备用。

tangteng822

ggmmlol 发表于 2020-1-13 12:15
我新发表了一个对工程量计算式求值的加载宏小工具，可以对任意格式的工作簿中的计算式进行快速计算（可“ ...

能不能帮忙看看45楼的情况，如何解决呢，谢谢

ggmmlol

tangteng822 发表于 2020-6-18 15:11
能不能帮忙看看45楼的情况，如何解决呢，谢谢

就给个图片看？

tangteng822

喔喔，不好意思，忘记了，嘿嘿。先开工程量这个文件，再开jss。谢谢

ggmmlol

tangteng822 发表于 2020-6-18 20:56
喔喔，不好意思，忘记了，嘿嘿。先开工程量这个文件，再开jss。谢谢

看了，头回见这种工程量计算式，抱歉，爱莫能助，因为这个自定义函数只能支持数学三角函数，也就是常见科学计算器上所提供的函数，并不是任意函数都可以处理的。