title: Run-time error '-2147221241 (80040107) while running VBA script in Outlook
body: <p>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. </p>
  
  <p>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: </p>
  
  <pre><code>RevdDate = Item.ReceivedTime 
  </code></pre>
  
  <p>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. </p>
  
  <p>Below is the entirety of the code:</p>
  
  <pre><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") &amp; "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") ' &lt;--- Update Fldr Name
  
              ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                      &amp; " - " &amp; _
                                              Item.Subject &amp; Ext
  
              ItemSubject = FileNameUnique(Path, ItemSubject, Ext)
  
              Item.SaveAs Path &amp; 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 &amp; FileName &amp; Chr(46) &amp; Ext) = True
          FileName = Left(FileName, lngName) &amp; " (" &amp; lngF &amp; ")"
          lngF = lngF + 1
      Loop
  
      FileNameUnique = FileName &amp; Chr(46) &amp; Ext
  
      Exit Function
  End Function
  </code></pre>
  
  <p>I would appreciate any help with this. </p>