爲什麼此腳本在創建66-ish PDF後停止？

Question

我寫了一個腳本，創建一個電子郵件的PDF版本，下面的這個版本確保電子郵件沒有附件（順便說一下，帶附件的版本的行爲方式完全一樣）。它運行順利，沒有出現任何問題，直到它到達65上下的電子郵件，然後將它與這個錯誤停止：

Run-Time error '-2147467259 (80004005)'

任何想法，爲什麼這可能發生？

這裏是我的代碼：

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 

謝謝您的幫助！

Answer 1

我仍然無法找到一個理由，爲什麼腳本會停止工作在65上下的電子郵件，但由於從@DmitryStreblechenko一些建議，我想出了這個「變通方法」解決方案：

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 

謝謝！