我正在尝试使用给this提供的解决方案,但是,每当我尝试运行最基本的东西时,我都会收到
Object not Defined
错误。我认为这是我的错(没有安装 ScriptControl)。但是,我尝试按照here中的描述进行安装,但没有成功。
我正在运行 Windows 7 Professional x64 和 Office 2010 64 位。
您可以创建类似
ScriptControl
的 ActiveX 对象,可通过 64 位 VBA 版本上的 mshta x86 主机在 32 位 Office 版本上使用,以下是示例(将代码放入标准 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
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
它有一些缺点:需要单独运行
mshta.exe
进程,该进程在任务管理器中列出,并按Alt+Tab显示隐藏的HTA窗口:
此外,您还必须通过
CreateObjectx86 Empty
关闭代码末尾的 HTA 窗口。
更新
您可以使主机窗口自动关闭:通过创建类实例或 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
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
将以下代码放入标准模块中:
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
第二种方法适用于那些由于某种原因不想使用类的人。要点是,mshta 窗口每 500 毫秒检查一次 VBA 的
Static oWnd
变量调用 CreateObjectx86
(不带参数)的状态,通过内部 setInterval()
函数每 500 毫秒检查一次,如果引用丢失(用户在 VBA 项目窗口中按下重置,或者工作簿已关闭(错误 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
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
更新2
由于注意到权限问题而拒绝
Scriptlet.TypeLib
。
对于 32 位版本的控件,可以使用 64 位替代版本。 Google for Tabalacus 脚本控件。 https://github.com/tablacus/TablacusScriptControl。如果需要,可以使用免费的 VS 版本来编译控件。
遗憾的是,scriptcontrol 只是一个 32 位组件,不能在 64 位进程中运行。