Question

我在Outlook中运行的VBA脚本应该将具有特定主题的传入电子邮件移动到Outlook中的子文件夹，然后将这些电子邮件导出到TXT文件。

这在大多数情况下都有效，但在导出几封电子邮件之后会出现以下消息：“运行时错误'-2147221241（80040107）'：操作失败。”弹出。我调试了它，它突出显示了代码行：

RevdDate = Item.ReceivedTime

出现此错误后，我可以重新启动Outlook，它通常会导出剩余的电子邮件而不会出现任何问题。但是我们需要完全自动化，所以我需要消除这个错误。

以下是整个代码：

    Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        SaveMailAsFile Item ' call sub
    End If
End Sub
Public Sub SaveMailAsFile(ByVal Item As Object)
    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim ItemSubject As String
    Dim NewName As String
    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String
    Dim i As Long

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")

    Path = Environ("ltvstatus") & "C:\Users\ltvstatus\Desktop\Backup Reports\"
    ItemSubject = Item.Subject
    RevdDate = Item.ReceivedTime
    Ext = "txt"

    For i = Items.Count To 1 Step -1
        Set Item = Items.Item(i)

        DoEvents

        If Item.Class = olMail Then
            Debug.Print Item.Subject ' Immediate Window
            Set SubFolder = Inbox.Folders("Reports") ' <--- Update Fldr Name

            ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                    & " - " & _
                                            Item.Subject & Ext

            ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

            Item.SaveAs Path & ItemSubject, olTXT
            Item.Move SubFolder
        End If
    Next

    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set Items = Nothing

End Sub


'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(FullName) Then
        FileExists = True
    Else
        FileExists = False
    End If

    Exit Function
End Function

'// If the same file name exist then add (1)
Private Function FileNameUnique(Path As String, _
                               FileName As String, _
                               Ext As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(FileName) - (Len(Ext) + 1)
    FileName = Left(FileName, lngName)

    Do While FileExists(Path & FileName & Chr(46) & Ext) = True
        FileName = Left(FileName, lngName) & " (" & lngF & ")"
        lngF = lngF + 1
    Loop

    FileNameUnique = FileName & Chr(46) & Ext

    Exit Function
End Function

我将不胜感激任何帮助。

Answer 1

此行接受ItemAdd代码传递给它的项目。

Public Sub SaveMailAsFile(ByVal Item As Object)

您有混合代码来处理一个项目和代码来处理许多项目。

您可以首先处理一个项目，然后查找之前可能已经遗漏的邮件，现在在收件箱中未经处理。

Private Sub SaveMailAsFile(ByVal Item As Object)

    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder

    Dim Items As Outlook.Items
    Dim ItemSubject As String

    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    If Item.Subject = "VVAnalyze Results" Then

        Path = Environ("ltvstatus") & "C:\Users\ltvstatus\Desktop\Backup Reports\"
        ItemSubject = Item.Subject
        RevdDate = Item.ReceivedTime
        Ext = "txt"

        Debug.Print Item.Subject ' Immediate Window

        Set SubFolder = Inbox.Folders("Reports") ' <--- Update Fldr Name

        ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                & " - " & _
                                        Item.Subject & Ext

        ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

        Item.SaveAs Path & ItemSubject, olTXT
        Item.Move SubFolder

    End If

    SaveMailAsFile_Standalone ' Comment out to run separately if needed

ExitRoutine:
    Set olNs = Nothing
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set Items = Nothing

End Sub

Public Sub SaveMailAsFile_Standalone()

    Dim olNs As NameSpace
    Dim Inbox As Folder
    Dim SubFolder As Folder

    Dim resItems As Items
    Dim unprocessedItem As Object

    Dim ItemSubject As String
    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String

    Dim i As Long

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Set resItems = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")

    Path = Environ("ltvstatus") & "C:\Users\ltvstatus\Desktop\Backup Reports\"
    'ItemSubject = Item.Subject
    'RevdDate = Item.ReceivedTime
    Ext = "txt"

    For i = resItems.count To 1 Step -1

        Set unprocessedItem = resItems.Item(i)

        DoEvents

        If unprocessedItem.Class = olMail Then

            ItemSubject = unprocessedItem.Subject
            RevdDate = unprocessedItem.ReceivedTime

            Debug.Print unprocessedItem.Subject ' Immediate Window

            Set SubFolder = Inbox.Folders("Reports") ' <--- Update Fldr Name

            ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                    & " - " & _
                                    unprocessedItem.Subject & Ext

            ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

            unprocessedItem.SaveAs Path & ItemSubject, olTXT
            unprocessedItem.Move SubFolder

        End If
    Next

ExitRoutine:
    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set resItems = Nothing
    Set unprocessedItem = Nothing

End Sub

Answer 2

错误是MAPI_E_INVALID_ENTRYID，这通常意味着传递给Namespace.GetItemfromID的条目ID无法识别。

您确定错误位置正确吗？您的脚本如何成功检索Subject属性，然后在ReceivedTime上失败？

在Outlook中运行VBA脚本时运行时错误'-2147221241（80040107）

2 个答案: