Run-time error '-2147221241 (80040107) returning Item.ReceivedTime

Question

I have a VBA script in Outlook to move incoming emails with a specific subject to a subfolder within Outlook, and then export those emails to TXT files.

After several emails are exported a message pops up.

"Run-time error '-2147221241 (80040107)': The Operation failed."

It is highlighting:

RevdDate = Item.ReceivedTime 

I can restart Outlook and it will usually export the remainder of the emails.

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

The error is MAPI_E_INVALID_ENTRYID, which usually means an entry id passed to Namespace.GetItemfromID cannot be recognized.

Are you sure you have the error location right? How is it possible for your script to successfully retrieve the Subject property and then fail on ReceivedTime?

Answer 2

This line accepts Item passed to it by the ItemAdd code.

Public Sub SaveMailAsFile(ByVal Item As Object)

You have intermixed code to handle one item and code to handle many items.

You could first process the one Item then look for mail that might have been missed previously and is now unprocessed in the Inbox.

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