我有以下生成字符串的UDF
Sub Test_ConvertToUnicode_UDF()
Dim s
s = ConvertToUnicode("الحديث")
Debug.Print Evaluate("""" & s & """")
End Sub
Function ConvertToUnicode(ByVal sInput As String)
Dim s As String, i As Long
For i = 1 To Len(sInput)
s = s & "Chr(" & Asc(Mid(sInput, i, 1)) & ")" & IIf(i <> Len(sInput), ", ", Empty)
Next i
ConvertToUnicode = "Join(Array(" & s & "), Empty)"
End Function
如何评估字符串输出,使其具有与在命令行中键入相同的结果? 我的意思是UDF将使用“الحديث”的字符串转换为该字符串
Join(Array(Chr(199), Chr(225), Chr(205), Chr(207), Chr(237), Chr(203)), Empty)
我如何评估该行能够像这样使用
Debug.Print Join(Array(Chr(199), Chr(225), Chr(205), Chr(207), Chr(237), Chr(203)), Empty)
也张贴在这里 https://www.mrexcel.com/board/threads/evaluate-string-to-join-1d-array.1140921/ http://www.eileenslounge.com/viewtopic.php?f=30&t=35014
答案 0 :(得分:1)
有一个示例显示了如何使用ScriptControl在VBA中评估VB表达式:
Option Explicit
Sub Test()
Dim oSC As Object
Set oSC = CreateObjectx86("ScriptControl")
oSC.Language = "VBScript"
Cells(1, 1).Value = oSC.Eval("Join(Array(ChrW(1575), ChrW(1604), ChrW(1581), ChrW(1583), ChrW(1610), ChrW(1579)), Empty)")
End Sub
Function CreateObjectx86(Optional sProgID)
Static oWnd As Object
Dim bRunning As Boolean
#If Win64 Then
bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
Select Case True
Case IsMissing(sProgID)
If bRunning Then oWnd.Lost = False
Exit Function
Case IsEmpty(sProgID)
If bRunning Then oWnd.Close
Exit Function
Case Not bRunning
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
oWnd.execScript "var Lost, App;": Set oWnd.App = Application
oWnd.execScript "Sub Check(): On Error Resume Next: Lost = True: App.Run(""CreateObjectx86""): If Lost And (Err.Number = 1004 Or Err.Number = 0) Then close: End If End Sub", "VBScript"
oWnd.execScript "setInterval('Check();', 500);"
End Select
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
Set CreateObjectx86 = CreateObject(sProgID)
#End If
End Function
Function CreateWindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
Dim sSignature, oShellWnd, oProc
On Error Resume Next
Do Until Len(sSignature) = 32
sSignature = sSignature & Hex(Int(Rnd * 16))
Loop
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
如果在Office 365上遇到错误
无法创建用于指定语言的脚本引擎
您可以按照以下说明进行修复:Registry key to re-enable VBScript controls in Office 365。
还有另外一个利用htmlfile Eval()
函数的代码,由于仅适用于Win 7,因此已过时,因此请谨慎使用:
Option Explicit
Sub test()
Dim sample
sample = "Join(Array(ChrW(1575), ChrW(1604), ChrW(1581), ChrW(1583), ChrW(1610), ChrW(1579)), Empty)"
Dim result
Dim valid
eval sample, result, valid
If valid Then
Cells(1, 1).Value = result
Else
Cells(1, 1).Value = "Oops"
End If
End Sub
Sub eval(expr, ret, ok)
Static htmlFile As Object
If htmlFile Is Nothing Then
Set htmlFile = CreateObject("htmlfile")
htmlFile.parentWindow.execScript "Function evalExpr(expr): evalExpr = Eval(expr): End Function", "vbscript"
End If
On Error Resume Next
ret = htmlFile.parentWindow.evalExpr(expr)
ok = Err.Number = 0
End Sub