Outlook VBA Email Autosave

Question

I'm using the code below to automatically save emails as they arrive. The issue I have is that emails that are only in the default inbox are saved. I've searched a bit and tried a few tweaks, but I'm new to VBA and nothing has seemed to work yet.

    Option Explicit

    Public Enum olSaveAsTypeEnum
      olSaveAsTxt = 0
      olSaveAsRTF = 1
      olSaveAsMsg = 3
    End Enum

    Private WithEvents Items As Outlook.Items

    Private Const MAIL_PATH As String = "C:\Users\xxxxx\My Documents\Emails\"

    Private Sub Application_Startup()
      Dim Ns As Outlook.NameSpace

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

    Private Sub Items_ItemAdd(ByVal Item As Object)
      If TypeOf Item Is Outlook.MailItem Then
        SaveMailAsFile Item, olSaveAsMsg, MAIL_PATH
      End If
    End Sub

    Private Sub SaveMailAsFile(oMail As Outlook.MailItem, _
      eType As olSaveAsTypeEnum, _
      sPath As String _
    )
      Dim dtDate As Date
      Dim sName As String
      Dim sFile As String
      Dim sExt As String

      Select Case eType
        Case olSaveAsTxt: sExt = ".txt"
        Case olSaveAsMsg: sExt = ".msg"
        Case olSaveAsRTF: sExt = ".rtf"
        Case Else: Exit Sub
      End Select

      sName = oMail.Subject
      ReplaceCharsForFileName sName, "_"

      dtDate = oMail.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & sExt

      oMail.SaveAs sPath & sName, eType
    End Sub

    Private Sub ReplaceCharsForFileName(sName As String, _
      sChr As String _
    )
      sName = Replace(sName, "/", sChr)
      sName = Replace(sName, "\", sChr)
      sName = Replace(sName, ":", sChr)
      sName = Replace(sName, "?", sChr)
      sName = Replace(sName, Chr(34), sChr)
      sName = Replace(sName, "<", sChr)
      sName = Replace(sName, ">", sChr)
      sName = Replace(sName, "|", sChr)
    End Sub

I have tried this change below.

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace

  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.Folders.Item("Inbox").Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    SaveMailAsFile Item, olSaveAsMsg, MAIL_PATH
  End If
End Sub

But I get an object not found error.

Solution 1

Its been a while and I can't believe I never marked this question complete, but I'm glad I didn't. I actually did find the best solution a little while ago and it does resemble a what niton said.

First create a class with the name cFolderItems and the following code:

Option Explicit

Private WithEvents pFolderItems As Outlook.Items

Public Property Set FolderItems(sFolder As Outlook.Items)
    Set pFolderItems = sFolder
End Property

Public Property Get FolderItems()
    Set FolderItems = pFolderItems
End Property

Private Sub pFolderItems_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        ' Save email function here
    End If
End Sub

Then in a separate module named whatever put the following code:

Option Explicit

Public pFolderEvents As Collection

Public oNS As Namespace
Public oInbox As folder

Dim eHandler As cFolderItems

Public Sub PopulateFolders()
    If Not SetCheck(pFolderEvents) Then
        Set pFolderEvents = New Collection
        Set oNS = Application.GetNamespace("MAPI")
        Set oInbox = oNS.GetDefaultFolder(olFolderInbox)

        RecursiveFolders oInbox
        TrashCleaner
    End If
End Sub

Function RecursiveFolders(rFolder As Folder) As folder
    Dim oSubFolder As Folder

    Set eHandler = New cFolderItems
    Set eHandler.FolderItems = rFolder.Items

    pFolderEvents.Add eHandler
    For Each oSubFolder In rFolder.Folders
        DoEvents
        RecursiveFolders oSubFolder
    Next
End Function

Function SetCheck(oObject) As Boolean
    If oObject Is Nothing Then
        SetCheck = False
    Else
        SetCheck = True
    End If
End Function

Function TrashCleaner()
    Set oNS = Nothing
    Set oInbox = Nothing
End Function

And in ThisOutlookSession

Option Explicit    

Private Sub Application_Startup()
    PopulateFolders
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' Just in case the objects become unset
    PopulateFolders
End Sub

Solution 2

I was able to figure out last night. Sorry for getting back so late. I'm using the script below with a rule that applies after receiving a message. I placed the rule at the top of the list to ensure they get saved. Has been working out great so far.

Public Sub saveEmailtoDisk(itm As Outlook.MailItem)

    Dim saveFolder As String
    Dim sName As String
    Dim from As String
    saveFolder = "C:\Users\xxxxxx\My Documents\Emails\"
    sName = itm.Subject
    from = itm.SenderName
    ReplaceCharsForFileName sName, "_"
    itm.SaveAs saveFolder & Format$(itm.CreationTime, "(mm-dd-yy)-") & from & "-" & sName & ".msg", olMSG
End Sub
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
End Sub

Solution 3

If you recursively loop you would resave old mail as well. This might be okay as the old file would be overwritten not duplicated.

You could try separate code for each subfolder.

Private WithEvents ItemsSub1 As Outlook.Items

Set ItemsSub1 = Ns.GetDefaultFolder(olFolderInbox).Folders("Sub1").Items

Private Sub ItemsSub1_ItemAdd(ByVal Item As Object)