Question

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

运行时错误＆＃39; -2147467259（80004005）＆＃39;

知道为什么会这样吗？

这是我的代码：

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-ish电子邮件的原因，但是由于@DmitryStreblechenko的一些建议，我提出了这个＆＃34;解决方法＆＃34;溶液：

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

谢谢！

为什么在创建66-ish PDF后此脚本会停止？

1 个答案: