Question

我有以下生成字符串的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

Answer 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

评估字符串以加入一维数组

1 个答案: