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

0

1

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://mcmap.net/q/57311/-ms-access-vba-error-run-time-error-39-70-39-permission-denied
    ' https://mcmap.net/q/57312/-vba-39-set-typelib-createobject-quot-scriptlet-typelib-quot-39-permission-denied-duplicate
    '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
Periscope answered 4/9, 2020 at 16:25 Comment(3)
"My goal is to generate strings that contain code to be evaluated" - could you please specify some code for strings generation or examples of generated string, just to know how much the code to be evaluated is differ from VBS syntax. So, what result of the evaluation is expected?Recommend
Actually the strings are pre-determined. I know that I could write the code with one procedure for each case, but was hoping to get things a little more organized and essentially, the test code that I show would address my needs.Periscope
First of all you should learn the Script Control functionality to know how to pass in the variables. Here some useful links Adding Scripting Support to Your Application (several pages are available via the side menu on the left), How To Use Script Control Modules and Procedures Collections, How To Call Functions Using the Script ControlRecommend

© 2022 - 2024 — McMap. All rights reserved.