vbaexcelcomexcel-2010scriptcontrol

Getting ScriptControl to work with Excel 2010 x64


I am trying to use the solution given to this, however, whenever I try to run the most basic anything, I get an Object not Defined error. I thought this would be my fault (not having installed ScriptControl). However, I tried installing as described in here, to no avail.

I am running Windows 7 Professional x64 with Office 2010 64 bit.


Solution

  • You can create ActiveX objects like ScriptControl, which is available on 32-bit Office versions via mshta x86 host on 64-bit VBA version, here is the example (put the code in a standard VBA project module):

    Option Explicit
    
    Sub Test()
        
        Dim oSC As Object
        
        Set oSC = CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host
        Debug.Print TypeName(oSC) ' ScriptControl
        ' do some stuff
        
        CreateObjectx86 Empty ' close mshta host window at the end
        
    End Sub
    
    Function CreateObjectx86(sProgID)
       
        Static oWnd As Object
        Dim bRunning As Boolean
        
        #If Win64 Then
            bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
            If IsEmpty(sProgID) Then
                If bRunning Then oWnd.Close
                Exit Function
            End If
            If Not bRunning Then
                Set oWnd = CreateWindow()
                oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
            End If
            Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
        #Else
            If Not IsEmpty(sProgID) Then 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
    

    It has few shortcomings: the separate mshta.exe process running is necessary, which is listed in task manager, and pressing Alt+Tab hidden HTA window is shown:

    enter image description here

    Also you have to close that HTA window at the end of your code by CreateObjectx86 Empty.

    UPDATE

    You can make the host window to be closed automatically: by creating class instance or mshta active tracing.

    First method assumes you create a class instance as a wrapper, which uses Private Sub Class_Terminate() to close the window.

    Note: if Excel crashes while code execution then there is no class termination, so the window will stay in background.

    Put the below code in a class module named cMSHTAx86Host:

        Option Explicit
        
        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
            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
    
        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
    

    Put the below code in a standard module:

    Option Explicit
    
    Sub Test()
        
        Dim oHost As New cMSHTAx86Host
        Dim oSC As Object
        
        Set oSC = oHost.CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host
        Debug.Print TypeName(oSC) ' ScriptControl
        ' do some stuff
        
        ' mshta window is running until oHost instance exists
        ' if necessary you can manually close mshta host window by oHost.Quit
        
    End Sub
    

    Second method for those who don't want to use classes for some reason. The point is that mshta window checks the state of VBA's Static oWnd variable calling CreateObjectx86 without argument via internal setInterval() function each 500 msec, and quits if the reference lost (either user have pressed Reset in VBA Project window, or the workbook has been closed (error 1004)).

    Note: VBA breakpoints (error 57097), worksheet cells edited by user, opened dialog modal windows like Open / Save / Options (error -2147418111) will suspend the tracing since they make application unresponsive for external calls from mshta. Such actions exceptions are handled, and after completion the code will continue to work, no crashes.

    Put the below code in a standard module:

    Option Explicit
    
    Sub Test()
        
        Dim oSC As Object
        
        Set oSC = CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host
        Debug.Print TypeName(oSC) ' ScriptControl
        ' do some stuff
        
        ' mshta window is running until Static oWnd reference to window lost
        ' if necessary you can manually close mshta host window by CreateObjectx86 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
    

    UPDATE 2

    Refused Scriptlet.TypeLib due to noticed permission issues.