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

This is working for the most part, but after several emails are exported the message: "Run-time error '-2147221241 (80040107)': The Operation failed." pops up. I debugged it and it is highlighting the line of code: 

```
RevdDate = Item.ReceivedTime 

```

Once this error appears I can restart Outlook and it will usually export the remainder of the emails with no issues. However we are needing this to be completely automated so I need to eliminate this error. 

Below is the entirety of the code:

```
    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

```

I would appreciate any help with this.