CODEWITHSUNDEEP
excelvba
YasserKhalil
YasserKhalil

Reputation: 9548

Evaluate string to join 1D array

I have the following UDF that generates a string

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

How can I evaluate the string output so as to be able to have the same result as if I typed it as command line? I mean the string used "الحديث" is converted by the UDF to that string

Join(Array(Chr(199), Chr(225), Chr(205), Chr(207), Chr(237), Chr(203)), Empty)

How can I evaluate the line to be able to use like that

Debug.Print Join(Array(Chr(199), Chr(225), Chr(205), Chr(207), Chr(237), Chr(203)), Empty)

Posted here too https://www.mrexcel.com/board/threads/evaluate-string-to-join-1d-array.1140921/ http://www.eileenslounge.com/viewtopic.php?f=30&t=35014

Upvotes: 1

Views: 110

Answers (1)

omegastripes
omegastripes

Reputation: 12612

There is an example showing how VB expressions can be evaluated in VBA using ScriptControl:

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

If you encounter the error on Office 365

A script engine for the specified language can not be created

You may fix that as described here: Registry key to re-enable VBScript controls in Office 365.

Also there is another code utilizing htmlfile Eval() function, it's outdated since works on Win 7 only, so use it with care:

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

Upvotes: 1

Related Questions