VBA MailMerge à partir d'Excel - Message d'erreur en attente d'une action OLE

Question

Bon Matin

Je suis en train de nettoyer une macro qui se comporte erraticly. Il a l'habitude de travailler - une bonne journée. Mais il génère cette erreur: "Microsoft Excel attend une autre application pour terminer une action OLE". J'ai essayé de le nettoyer (ce qui a causé toutes sortes d'autres erreurs, maintenant triées) et je suis de retour à pouvoir le traverser mais il s'arrête de nouveau à l'erreur ci-dessus. Ce que j'ai remarqué qu'il faisait un certificat et ensuite lancer l'erreur mais maintenant l'erreur se produit tout de suite quand il essaie d'ouvrir le modèle. Ceci est la ligne: Set objMMMD = objWord.Documents.Open (REDC & WTempName) objMMMD.Activate

Ma pensée originale était que le code n'a pas fermer Word proprement mais maintenant que l'erreur est si tôt, que ça ne peut pas être ça. Je n'ai pas Word ouvert. - Comme il avait l'habitude d'ouvrir Word avant ma révision, le code devrait aussi être correct.

Je ne peux pas trouver beaucoup sur l'erreur, sauf qu'il semble se produire dans des codes plus complexes en raison de timeout et comment supprimer le message. Ni l'un ni l'autre ne semble être utile ici.

Sous l'intégralité du code. Est-ce que quelqu'un a une idée pourquoi Excel ne peut pas ouvrir Word pour faire le mailmerge?

Public Sub MailMergeCert() 

Dim bCreatedWordInstance As Boolean 
Dim objWord As Word.Application 
Dim objMMMD As Word.Document 

Dim FirstName As String 
Dim LastName As String 
Dim Training As String 
Dim SeminarDate As String 
Dim HoursComp As String 
Dim Location As String 
Dim Objectives As String 
Dim Trainer As String 

Dim cDir As String 
Dim ThisFileName As String 

'Your Sheet names need to be correct in here 
Dim sh1 As Worksheet 
Set sh1 = ActiveWorkbook.Sheets("Ultrasound") 

Dim r As Long 
r = 2 

FirstName = sh1.Cells(r, 1).Value 
LastName = sh1.Cells(r, 2).Value 
Training = sh1.Cells(r, 3).Value 
SeminarDate = Format(sh1.Cells(r, 4).Value, "d mmmm YYYY") 
HoursComp = sh1.Cells(r, 5).Value 
Location = sh1.Cells(r, 6).Value 
Objectives = sh1.Cells(r, 7).Value 
Trainer = sh1.Cells(r, 8).Value 

'Setup filenames 
Const WTempName = "Certificate_Ultrasound_2017.docx" 'Template name 

'Data Source Location 
cDir = ActiveWorkbook.Path + "\" 'Change if required 
ThisFileName = ThisWorkbook.Name 

On Error Resume Next 

'Create Word instance 
bCreatedWordInstance = False 
Set objWord = CreateObject("Word.Application") 

If objWord Is Nothing Then 
    Err.Clear 
    Set objWord = CreateObject("Word.Application") 
    bCreatedWordInstance = True 
    End If 

If objWord Is Nothing Then 
    MsgBox "Could not start Word" 
    Err.Clear 
    On Error GoTo 0 
    Exit Sub 
End If 

' Let Word trap the errors 
On Error GoTo 0 

' Set to True if you want to see the Word Doc flash past during construction 
objWord.Visible = False 

'Open Word Template 
Set objMMMD = objWord.Documents.Open(cDir & WTempName) 
objMMMD.Activate 

'Merge the data 
With objMMMD 
    .MailMerge.OpenDataSource Name:=cDir & ThisFileName, _ 
     sqlstatement:="SELECT * FROM `Ultrasound$`" ' Set this as required 

lastrow = Sheets("Ultrasound").Range("A" & Rows.Count).End(xlUp).Row 


     For r = 2 To lastrow 
     If IsEmpty(Cells(r, 11).Value) = False Then GoTo nextrow 

      With objMMMD.MailMerge 'With ActiveDocument.MailMerge 
      .Destination = wdSendToNewDocument 
      .SuppressBlankLines = True 

      With .DataSource 
       .FirstRecord = r - 1 
       .LastRecord = r - 1 
       .ActiveRecord = r - 1 
      End With 
      .Execute Pause:=False 
      End With 

'Save new file PDF 
Dim UltrasoundCertPath As String 
UltrasoundCertPath = "C:\Users\305015724\Documents\ApplicationsTraining\2016\Ultrasound\" 
Dim YYMM As String 
YYMM = Format(sh1.Cells(r, 16).Value, "YYMM") 
Dim NewFileNamePDF As String 
NewFileNamePDF = YYMM & "_" & sh1.Cells(r, 3).Value & "_" & sh1.Cells(r, 7).Value '& ".pdf" 'Change File Name as req'd" 
objWord.ActiveDocument.ExportAsFixedFormat UltrasoundCertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF 

nextrow: 
     Next r 

End With 


' Close the Mail Merge Main Document 
objMMMD.Close savechanges:=wdDoNotSaveChanges 
Set objMMMD = Nothing 
If bCreatedWordInstance Then 
objWord.Quit 
End If 

Set objWord = Nothing 
Cells(r, 11).Value = Date 

0: 
Set objWord = Nothing 

End Sub 

Answer 1

Essayez de changer

cDir = ActiveWorkbook.Path + "\" 

Pour

cDir = ActiveWorkbook.Path & "\" 

Est-ce que faire une différence. Essayez aussi d'imprimer le cDir si c'est ce que vous attendez. Essayez la boîte de message cDir pour vérifier le chemin d'accès.

MsgBox(cDir, vbOKOnly, "Testing cDir")