解决Access VBA调用外部程序时出现的「应用程序未响应」错误

问题根因 #

该弹窗是Access默认的OLE服务器忙提示，本质是ScriptControl同步执行长耗时的SAP数据提取逻辑时，阻塞了Access的UI线程，系统判定程序无响应就触发了该弹窗，手动点击重试后相当于恢复了线程执行权限，所以脚本会继续运行。

可用解决方案 #

方案1：修改Access OLE交互配置（最简单，无额外逻辑） #

执行ScriptControl代码前调整Access的OLE参数，延长超时时间、设置自动重试即可：

' 执行脚本前修改配置
Application.OleServerBusyTimeout = 3600000 ' 超时时间设为1小时，单位毫秒，可按需调整
Application.OleServerBusyRaiseError = False ' 不抛出错误，自动重试
Application.AutomationSecurity = msoAutomationSecurityLow ' 降低脚本安全限制避免拦截

' 你的原业务代码
Open scriptPath For Input As #1
vbsCode = Input$(LOF(1), 1)
Close #1

On Error GoTo ERR_VBS

With CreateObject("ScriptControl")
    .Language = "VBScript"
    .AddCode vbsCode
End With

' 执行完后恢复默认配置，避免影响其他功能
Application.OleServerBusyTimeout = 10000 ' 恢复默认10秒超时
Application.OleServerBusyRaiseError = True

方案2：API自动检测弹窗并点击重试 #

如果方案1不生效，可通过Win32 API循环检测弹窗自动点击重试，首先在模块顶部声明API：

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Const BM_CLICK = &HF5

' 检测并点击重试按钮的子程序
Sub CheckAndClickRetry()
    Dim hWndAccess As LongPtr, hWndBtn As LongPtr
    ' 窗口标题按实际弹窗标题修改，通常为"Microsoft Access"
    hWndAccess = FindWindow(vbNullString, "Microsoft Access")
    If hWndAccess <> 0 Then
        ' 按钮文本按实际弹窗按钮内容修改，通常为"重试(&R)"
        hWndBtn = FindWindowEx(hWndAccess, 0, vbNullString, "重试(&R)")
        If hWndBtn <> 0 Then
            SendMessage hWndBtn, BM_CLICK, 0, 0
        End If
    End If
    DoEvents ' 释放UI线程资源避免卡死
End Sub

在执行长耗时代码前开启Access计时器，每隔1秒调用一次CheckAndClickRetry即可，脚本执行完成后关闭计时器。

方案3：异步执行VBS脚本（彻底解决阻塞，适合超大数据量） #

不要用ScriptControl同步加载执行，直接让VBS脚本独立后台运行，Access等待执行完成后读取结果即可，完全不会阻塞主线程：

Sub RunVBSAsync(scriptPath As String, outputPath As String)
    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")
    ' 后台无窗口执行VBS，等待执行完成再继续
    wsh.Run "wscript.exe """ & scriptPath & """", 0, True
    ' 提前修改你的VBS脚本，把提取到的SAP数据写入outputPath（比如CSV格式）
    ' 执行完成后Access直接导入该结果文件即可
End Sub

x86宿主报错修复 #

你之前尝试的方案报错是因为hta运行上下文限制了业务脚本的对象创建，调整CreateObjectx86函数，仅用它创建ScriptControl对象即可，不要把业务脚本放在hta中执行：

Function CreateObjectx86(sProgID)
    Static oWnd As Object
    Dim sSignature, oShellWnd
    On Error Resume Next
    If sProgID = Empty Then
        Set oWnd = Nothing
        Exit Function
    End If
    If oWnd Is Nothing Then
        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>function CreateObjectx86(id){return new ActiveXObject(id);}shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
        Do
            For Each oShellWnd In CreateObject("Shell.Application").Windows
                Set oWnd = oShellWnd.GetProperty(sSignature)
                If Err.Number = 0 Then Exit Do
                Err.Clear
            Next
        Loop
    End If
    Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
End Function

内容的提问来源于stack exchange，提问作者Goku