为什么这个脚本在创建 66-ish PDF 后停止？答案

【问题标题】：Why does this script stops after creating 66-ish PDF?为什么这个脚本在创建 66-ish PDF 后停止？
【发布时间】：2017-11-27 09:48:36
【问题描述】：

我编写了一个脚本来创建电子邮件的 PDF 版本，下面的这个版本确保电子邮件没有附件（顺便说一下，带有附件的版本的行为方式完全相同）。它运行平稳，没有任何问题，直到它到达 65-ish 电子邮件，然后它停止并出现以下错误：

运行时错误'-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

感谢您的帮助！

【问题讨论】：

您的收件箱是否包含仅个邮件项目，还是有任何其他类型的项目？如果您只想处理邮件，请添加myItem 类型的检查。哪一行抛出错误？
是的，该收件箱仅包含邮件项目，而引发错误的行是：Set objInspector = myItem.GetInspector 紧跟在If FileOrDirExists(FolderPath & FileName & ".pdf") Then 之后
在循环中不触摸 Inspector 和 Word 编辑器是否还会出现同样的问题？
嗨 @DmitryStreblechenko 我对 VBA 还是很陌生，所以我不确定如何避免这样做......
@DmitryStreblechenko 我刚刚用 Inspector 和 Word 注释掉了整个部分，脚本在整个文件夹中“循环”没有任何问题。

标签： vba pdf outlook pdf-generation

【解决方案1】：

我仍然无法找到脚本停止处理 65-ish 电子邮件的原因，但感谢 @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

谢谢！

【讨论】：