Why does this script stops after creating 66-ish PDF? - vba

Question

I wrote a script that creates a PDF version of an email, this version below makes sure that an email doesn't have an attachment (version with attachment behaves in exactly the same way, by the way). It runs smoothly and without any problems until it reaches the 65-ish email, and then it stops with this error:
Run-Time error '-2147467259 (80004005)'
Any idea why this might be happening?
Here is my 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
Thank you for your help!

Answer 1

I'm still unable to find a reason why the script would stop working around 65-ish email, but thanks to a few suggestions from #DmitryStreblechenko I came up with this "workaround" solution:
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
Thank you!