Evaluating a string containing VBA code in MS Word and Getting ScriptControl to work

385 views Asked by At

My goal is to generate strings that contain code to be evaluated for a given set of variables. I found some similar efforts in these questions:

  1. VBA execute code in string
  2. How can I evaluate a string into an object in VBA?

Because in the code provided above in (2) there are issues with ScriptControl in x64, I found some patch for this at:

  1. Getting ScriptControl to work with Excel 2010 x64

Unfortunately, there were more issues as due to some windows patches, the GUID could not be issued. This prevented sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38) to return a proper GUID due to lack of permission.

This was highlighted in the following posts:

  1. MS Access VBA Error: Run time error '70' Permission Denied
  2. VBA 'set typelib = createobject("scriptlet.typelib")' Permission Denied

Based on the reference (5), I added some code to generate the GUID.

Unfortunately, this code is still not working and I keeo getting an error code # 13, "Type mismatch", when executing: oShellWnd.GetProperty(sSignature).

Note: I think the code for cMSHTAx86Host should be changed to avoid looping indefinitely (probably will only allow a certain number of retry and maybe a short pause between, to avoid an infinite loop and hog the processor).

I would very much like some help and posted below the code that I used below.

  1. A class cMSHTAx86Host ( cMSHTAx86Host.cls)
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cMSHTAx86Host"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As LongPtr
#Else
    Declare Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As Long
#End If

Private oWnd As Object

Private Sub Class_Initialize()
    
    #If Win64 Then
        Set oWnd = CreateWindow()
        oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
    #End If
    
End Sub

Private Function CreateWindow()
    
    ' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
    Dim sSignature, oShellWnd, oProc
    
    On Error Resume Next
    'Bug due to security patch see:
    ' https://stackoverflow.com/questions/45332357/ms-access-vba-error-run-time-error-70-permission-denied
    ' https://stackoverflow.com/questions/45082258/vba-set-typelib-createobjectscriptlet-typelib-permission-denied
    'sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    sSignature = Left(GenerateGUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe        '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
        'TODO: need to include code here to sleep and avoid infinite loops
    Loop
    
End Function

Function CreateObjectx86(sProgID)
    
    #If Win64 Then
        If InStr(TypeName(oWnd), "HTMLWindow") = 0 Then Class_Initialize
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject(sProgID)
    #End If
    
End Function

Function Quit()
    
    #If Win64 Then
        If InStr(TypeName(oWnd), "HTMLWindow") > 0 Then oWnd.Close
    #End If
    
End Function

Private Sub Class_Terminate()
    
    Quit
    
End Sub


Private Function GenerateGUID() As String
    Dim ID(0 To 15) As Byte
    Dim N As Long
    Dim GUID As String
    Dim Res As Long
    Res = CLng(CoCreateGuid(ID(0)))

    For N = 0 To 15
        GUID = GUID & IIf(ID(N) < 16, "0", "") & Hex$(ID(N))
        If Len(GUID) = 8 Or Len(GUID) = 13 Or Len(GUID) = 18 Or Len(GUID) = 23 Then
            GUID = GUID & "-"
        End If
    Next N
    GenerateGUID = GUID
End Function

Public Function eval(strEvalContent As String) As Object
    With CreateObjectx86("ScriptControl")
        .Language = "VBScript"
        .AddObject "app", Application, True
        Set eval = .eval(strEvalContent)
    End With
End Function
  1. A module as shown below (Note that I am unsure how to pass in the variables available when running oHost.eval)
Sub testEvalCode()
    Dim strEvalContent As String
    Dim oHost As New cMSHTAx86Host
    
    Dim oResult As Object
    someText = "Value"
    strEvalContent = "someText & "" - added"""
    Set oResult = oHost.eval(strEvalContent) 'unsure how to pass all variable available for the evaluation
    MsgBox CStr(objQueryTable) 'NOTE, I am yet unsure how the oResult will look like
End Sub
0

There are 0 answers