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 

ありがとう！