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:
Because in the code provided above in (2) there are issues with ScriptControl
in x64, I found some patch for this at:
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:
- MS Access VBA Error: Run time error '70' Permission Denied
- 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.
- 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
- 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