使ScriptControl与Excel 2010 x64一起使用

Question

使ScriptControl与Excel 2010 x64一起使用

Pro*_*oto 7 com vba excel-vba scriptcontrol excel-2010

我尝试使用给予解决这个,但是,每当我尝试运行最基础的东西,我得到一个Object not Defined错误.我认为这将是我的错(没有安装ScriptControl).但是,我尝试按此处所述进行安装,但无济于事.

我正在使用Office 2010 64位运行Windows 7 Professional x64.

Answer 1

您可以ScriptControl通过64位VBA版本上的mshta x86主机创建在32位Office版本上可用的ActiveX对象,这是示例(将代码放在标准VBA项目模块中):

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
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    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

Run Code Online (Sandbox Code Playgroud)

它有一些缺点:mshta.exe必须运行单独的进程,在任务管理器中列出,并显示按下Alt+ Tab隐藏的HTA窗口:

此外,您必须关闭代码末尾的HTA窗口CreateObjectx86 Empty.

UPDATE

您可以自动关闭主机窗口:通过创建类实例或mshta活动跟踪.

第一种方法假定您创建一个类实例作为包装器,Private Sub Class_Terminate()用于关闭窗口.

注意:如果Excel在代码执行时崩溃,那么没有类终止,因此窗口将保留在后台.

将以下代码放在名为的类模块中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
        sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
        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

Run Code Online (Sandbox Code Playgroud)

将以下代码放在标准模块中:

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

Run Code Online (Sandbox Code Playgroud)

第二种方法适用于那些因某些原因不想使用类的人.关键是mshta窗口每隔500毫秒通过内部函数检查VBA Static oWnd变量调用的状态CreateObjectx86而没有参数setInterval(),如果引用丢失(用户在VBA项目窗口中按下Reset,或者工作簿已关闭(错误1004)),则退出.

注意:VBA断点(错误57097),用户编辑的工作表单元格,打开的对话框模式窗口(如打开/保存/选项(错误-2147418111))将暂停跟踪,因为它们使应用程序无响应来自mshta的外部调用.处理此类操作异常,完成后代码将继续工作,不会崩溃.

将以下代码放在标准模块中:

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
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    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

Run Code Online (Sandbox Code Playgroud)

这应该是公认的答案，就像魅力一样 (2认同)

Answer 2

小智 5

对于 32 位版本的控件，可以使用 64 位替代品。Google for Tabalacus 脚本控件。https://github.com/tablacus/TablacusScriptControl。如果需要，可以使用免费的 VS 版本来编译控件。

这就像一个魅力，应该是公认的答案！ (2认同)

归档时间：	13 年，6 月前
查看次数：	16121 次
最近记录：	7 年，1 月前