vba 如何处理“Microsoft Excel 正在等待另一个应用程序完成 OLE 操作”

How to deal with "Microsoft Excel is waiting for another application to complete an OLE action"

提问by Martin Dreher

When automating other MS-Office applications with excel, I frequently get ok-only prompts saying that Microsoft Excel is waiting for another application to complete an OLE action.

使用 excel 自动化其他 MS-Office 应用程序时，我经常收到 ok-only 提示说 Microsoft Excel is waiting for another application to complete an OLE action.

This only happens when automating lengthy tasks.

这仅在自动化冗长的任务时发生。

How can I deal with this in an appropriate fashion?

我该如何以适当的方式处理这个问题？

Two recent examples (I recon the code is less important):

最近的两个例子（我认为代码不太重要）：

• creating an accdb-Database from Excel with an Access.Applicationand populating it by running rather complex SQL-queries on large amount of data.

  Public Function createDB(pathDB As String, pathSQL As String) As String
  
      Dim dbs As DAO.Database
      Dim sql As String
      Dim statement As Variant, file As Variant
  
      Dim sErr As String, iErr As Integer
  
      With New Access.Application
  
          With .DBEngine.CreateDatabase(pathDB, dbLangGeneral)
  
              For Each file In Split(pathSQL, ";")
  
                  sql = fetchSQL(file)
                  For Each statement In Split(sql, ";" & vbNewLine)
                      If Len(statement) < 5 Then GoTo skpStatement
                      Debug.Print statement
  
                      On Error Resume Next
                      .Execute statement, dbFailOnError
  
                      With Err
                          If .Number <> 0 Then
                              iErr = iErr + 1
                              sErr = sErr & vbCrLf & "Error " & .Number & " | " & Replace(.Description, vbCrLf, vbNullString)
                              .Clear
                          End If
                      End With
                      On Error GoTo 0
  skpStatement:
                  Next statement
              Next file
          End With
          .Quit acQuitSaveAll
      End With
  
      dTime = Now() - starttime
  
      ' Returnwert
      If sErr = vbNullString Then sErr = "Keine Fehler"
      createDB = "Zeit: " & Now & " | Dauer: " & Format(dTime, "hh:mm:ss") & " | Anzahl Fehler: " & iErr & vbCrLf & sErr
  
      ' Log
      With ThisWorkbook
          '...
          .Saved = True
          .Save
      End With
  
  End Function
  

• create mail merges from Excel in a Word.Application, using existing and rather large .docm-templates and dynamic SQL-queries that returns the receipents

  Set rst = GetRecordset(ThisWorkbook.Sheets("Parameter").Range("A1:S100"))
  
  With New Word.Application
  
      .Visible = False
  
      While Not rst.EOF
          If rst!Verarbeiten And Not IsNull(rst!Verarbeiten) Then
              Debug.Print rst!Sql
  
              .Documents.Open rst!inpath & Application.PathSeparator & rst!infile
              stroutfile = fCheckPath(rst!outpath, True) & Application.PathSeparator & rst!outfile
  
              .Run "quelle_aendern", rst!DataSource, rst!Sql
  
              .Run MacroName:="TemplateProject.AutoExec.SeriendruckInDokument"
  
              Application.DisplayAlerts = False
  
              .ActiveDocument.ExportAsFixedFormat _
                  OutputFileName:=stroutfile _
                  , ExportFormat:=wdExportFormatPDF _
                  , OpenAfterExport:=False _
                  , OptimizeFor:=wdExportOptimizeForPrint _
                  , Range:=wdExportAllDocument _
                  , From:=1, To:=1 _
                  , Item:=wdExportDocumentContent _
                  , IncludeDocProps:=False _
                  , KeepIRM:=True _
                  , CreateBookmarks:=wdExportCreateNoBookmarks _
                  , DocStructureTags:=False _
                  , BitmapMissingFonts:=True _
                  , UseISO19005_1:=False
  
              Application.DisplayAlerts = True
  
              For Each doc In .Documents
                  With doc
                      .Saved = True
                      .Close SaveChanges:=wdDoNotSaveChanges
                  End With
              Next doc
  
          End If
          rst.MoveNext
      Wend
  
      .Quit
  End With
  

• 从 Excel 创建一个 accdb-DatabaseAccess.Application并通过对大量数据运行相当复杂的 SQL 查询来填充它。

  Public Function createDB(pathDB As String, pathSQL As String) As String
  
      Dim dbs As DAO.Database
      Dim sql As String
      Dim statement As Variant, file As Variant
  
      Dim sErr As String, iErr As Integer
  
      With New Access.Application
  
          With .DBEngine.CreateDatabase(pathDB, dbLangGeneral)
  
              For Each file In Split(pathSQL, ";")
  
                  sql = fetchSQL(file)
                  For Each statement In Split(sql, ";" & vbNewLine)
                      If Len(statement) < 5 Then GoTo skpStatement
                      Debug.Print statement
  
                      On Error Resume Next
                      .Execute statement, dbFailOnError
  
                      With Err
                          If .Number <> 0 Then
                              iErr = iErr + 1
                              sErr = sErr & vbCrLf & "Error " & .Number & " | " & Replace(.Description, vbCrLf, vbNullString)
                              .Clear
                          End If
                      End With
                      On Error GoTo 0
  skpStatement:
                  Next statement
              Next file
          End With
          .Quit acQuitSaveAll
      End With
  
      dTime = Now() - starttime
  
      ' Returnwert
      If sErr = vbNullString Then sErr = "Keine Fehler"
      createDB = "Zeit: " & Now & " | Dauer: " & Format(dTime, "hh:mm:ss") & " | Anzahl Fehler: " & iErr & vbCrLf & sErr
  
      ' Log
      With ThisWorkbook
          '...
          .Saved = True
          .Save
      End With
  
  End Function
  

• Word.Application使用现有的相当大的.docm模板和返回接收者的动态 SQL 查询，从 Excel 中创建邮件合并

  Set rst = GetRecordset(ThisWorkbook.Sheets("Parameter").Range("A1:S100"))
  
  With New Word.Application
  
      .Visible = False
  
      While Not rst.EOF
          If rst!Verarbeiten And Not IsNull(rst!Verarbeiten) Then
              Debug.Print rst!Sql
  
              .Documents.Open rst!inpath & Application.PathSeparator & rst!infile
              stroutfile = fCheckPath(rst!outpath, True) & Application.PathSeparator & rst!outfile
  
              .Run "quelle_aendern", rst!DataSource, rst!Sql
  
              .Run MacroName:="TemplateProject.AutoExec.SeriendruckInDokument"
  
              Application.DisplayAlerts = False
  
              .ActiveDocument.ExportAsFixedFormat _
                  OutputFileName:=stroutfile _
                  , ExportFormat:=wdExportFormatPDF _
                  , OpenAfterExport:=False _
                  , OptimizeFor:=wdExportOptimizeForPrint _
                  , Range:=wdExportAllDocument _
                  , From:=1, To:=1 _
                  , Item:=wdExportDocumentContent _
                  , IncludeDocProps:=False _
                  , KeepIRM:=True _
                  , CreateBookmarks:=wdExportCreateNoBookmarks _
                  , DocStructureTags:=False _
                  , BitmapMissingFonts:=True _
                  , UseISO19005_1:=False
  
              Application.DisplayAlerts = True
  
              For Each doc In .Documents
                  With doc
                      .Saved = True
                      .Close SaveChanges:=wdDoNotSaveChanges
                  End With
              Next doc
  
          End If
          rst.MoveNext
      Wend
  
      .Quit
  End With
  

notes:

笔记：

• When run on a smaller scale (for example, when querying less records or using less complex templates), both codes do run smoothly.
• In both cases, when I OKthrough all the reappearing prompts, the code will eventually finish with the desired results. Therefore, I guess I'm not encountering an error (also it doesn't trigger the error handlers), but rather something like a timeout.

• 当以较小的规模运行时（例如，查询较少的记录或使用较不复杂的模板时），这两种代码都可以顺利运行。
• 在这两种情况下，当我OK通过所有重新出现的提示时，代码最终将获得所需的结果。因此，我想我没有遇到错误（它也不会触发错误处理程序），而是遇到超时之类的事情。

As suggested on other sources, I do wrap my code into Application.DisplayAlerts = False. This, however, seems like a horrible idea, since there might actually be cases where I do need to be alerted.

正如其他来源所建议的那样，我确实将代码包装到Application.DisplayAlerts = False. 然而，这似乎是一个可怕的想法，因为实际上可能存在需要提醒我的情况。

回答by Darren Bartrup-Cook

I'll add the code that @Tehscript linked to in the comments.

我将在评论中添加@Tehscript 链接的代码。

You can solve this by using the COM API to remove VBA's message filter. This will prevent COM from telling VBA to displaying a message box when it thinks the process you're calling has blocked. Note that if the process really has blocked for some reason this will prevent you from receiving any notification of that. [source]

您可以通过使用 COM API 删除 VBA 的消息过滤器来解决此问题。这将阻止 COM 在认为您正在调用的进程已被阻止时告诉 VBA 显示消息框。请注意，如果该进程因某种原因确实被阻止，这将阻止您收到任何通知。[来源]

I think this is the code I used back in 2006 for the same problem (it worked).

我认为这是我在 2006 年用于解决同一问题的代码（它有效）。

Private Declare Function _
    CoRegisterMessageFilter Lib "OLE32.DLL" _
    (ByVal lFilterIn As Long, _
    ByRef lPreviousFilter) As Long

Sub KillMessageFilter()  
    '''Original script Rob Bovey  

    '''https://groups.google.com/forum/?hl=en#!msg/microsoft.public.excel.programming/ct8NRT-o7rs/jawi42S8Ci0J
    '''http://www.appspro.com/

    Dim lMsgFilter As Long

    ''' Remove the message filter before calling Reflections.
    CoRegisterMessageFilter 0&, lMsgFilter

    ''' Call your code here....

    ''' Restore the message filter after calling Reflections.
    CoRegisterMessageFilter lMsgFilter, lMsgFilter

End Sub