Pourquoi ce script s'arrête-t-il après la création du fichier PDF 66-ish?

Question

J'ai écrit un script qui crée une version PDF d'un email, cette version ci-dessous s'assure qu'un email n'a pas de pièce jointe (la version avec pièce jointe se comporte exactement de la même manière, soit dit en passant). Il fonctionne en douceur et sans aucun problème jusqu'à ce qu'il atteigne 65-ish email, puis il arrête avec cette erreur:

Run-Time error '-2147467259 (80004005)'

Toute idée pourquoi cela pourrait se produire?

Voici mon code:

Sub PrintEmails() 

Dim olApp As Outlook.Application 
Dim objNS As Outlook.NameSpace 
Dim olFolder As Outlook.MAPIFolder 
Dim myItem As Object, myItems As Object, objDoc As Object, objInspector As Object 
Dim FolderPath As String 
Dim FileNumber As Long 

FileNumber = 2 

Set olApp = Outlook.Application 
Set objNS = olApp.GetNamespace("MAPI") 
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("NewEmails") 
Set myItems = olFolder.Items 

FolderPath = "F:\MyFolder\VBA\Emails\" 


For Each myItem In myItems 

If myItem.Attachments.Count = 0 Then 

    FileName = myItem.Subject 
    IllegalCharacters = Array("/", "\", ":", "?", "<", ">", "|", "&", "%", "*", "{", "}", "[", "]", "!") 
     For Each Character In IllegalCharacters 
      FileName = Replace(FileName, Character, " ") 
     Next Character 


    Do While FileOrDirExists(FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".pdf") 
     FileNumber = FileNumber + 1 
    Loop 

    If FileOrDirExists(FolderPath & FileName & ".pdf") Then 
     Set objInspector = myItem.GetInspector 
     Set objDoc = objInspector.WordEditor 
     objDoc.ExportAsFixedFormat FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".pdf", 17 
     Set objInspector = Nothing 
     Set objDoc = Nothing 
     FileNumber = FileNumber + 1 
    Else 
     Set objInspector = myItem.GetInspector 
     Set objDoc = objInspector.WordEditor 
     objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17 
     Set objInspector = Nothing 
     Set objDoc = Nothing 
    End If 

Else 

End If 

Next myItem 


End Sub 

Function FileOrDirExists(PathName As String) As Boolean 

Dim iTemp As Integer 

'Ignore errors to allow for error evaluation 
On Error Resume Next 
iTemp = GetAttr(PathName) 

'Check if error exists and set response appropriately 
Select Case Err.Number 
Case Is = 0 
    FileOrDirExists = True 
Case Else 
    FileOrDirExists = False 
End Select 

'Resume error checking 
On Error GoTo 0 
End Function 

Merci pour votre aide!

Answer 1

Je suis toujours incapable de trouver une raison pour laquelle le script arrêterait travail e-mail environ 65-ish, mais grâce à quelques suggestions de @DmitryStreblechenko je suis venu avec cette solution « de contournement »:

Sub PrintEmails() 

Dim olApp As Outlook.Application 
Dim objNS As Outlook.NameSpace 
Dim olFolder As Outlook.MAPIFolder 
Dim myItem As Object, myItems As Object 
Dim FolderPath As String 
Dim FileNumber As Long 
Dim objWord As Object, objDoc As Object 
Set objWord = CreateObject("Word.Application") 
Set objDoc = objWord.Documents 

FileNumber = 2 

Set olApp = Outlook.Application 
Set objNS = olApp.GetNamespace("MAPI") 
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("NewEmails") 
Set myItems = olFolder.Items 

FolderPath = "F:\MyFolder\VBA\Emails\" 

For Each myItem In myItems 

If myItem.Attachments.Count = 0 Then 
    FileName = myItem.SenderName 

    IllegalCharacters = Array("/", "\", ":", "?", "<", ">", "|", "&", "%", "*", "{", "}", "[", "]", "!") 
     For Each Character In IllegalCharacters 
      FileName = Replace(FileName, Character, " ") 
     Next Character 

    Do While FileOrDirExists(FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".doc") 
     FileNumber = FileNumber + 1 
    Loop 

    If FileOrDirExists(FolderPath & FileName & ".doc") Then 
     myItem.SaveAs FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".doc", olDoc 
     FileNumber = FileNumber + 1 
    Else 
     myItem.SaveAs FolderPath & FileName & ".doc", olDoc 
    End If 
    FileNumber = 2 
Else 
End If 

FileNumber = 2 

Next myItem 

wFile = Dir(FolderPath & "*.doc") 

Do While wFile <> "" 
    Set objDoc = objWord.Documents.Open(FolderPath & wFile) 
    objDoc.ExportAsFixedFormat OutputFileName:=FolderPath & Replace(wFile, ".doc", ".pdf"), ExportFormat:=wdExportFormatPDF 
    objDoc.Close (True) 
    wFile = Dir 
Loop 
objWord.Quit 

End Sub 

Function FileOrDirExists(PathName As String) As Boolean 

    Dim iTemp As Integer 

    'Ignore errors to allow for error evaluation 
    On Error Resume Next 
    iTemp = GetAttr(PathName) 

    'Check if error exists and set response appropriately 
    Select Case Err.Number 
    Case Is = 0 
     FileOrDirExists = True 
    Case Else 
     FileOrDirExists = False 
    End Select 

    'Resume error checking 
    On Error GoTo 0 
End Function 

Merci!