Save email to a folder if subject line matches

Question

I'm trying to save an email, when it arrives, into a folder if the subject line contains the right term.

This code would end up being copied for 75-80 items all with varying subject lines.

Option Explicit

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
    Dim msgNew As MailItem
    Dim DateYr As Object
    Dim DateMonth As Object

    If objItem.Class = olMail Then
        Set msgNew = objItem
        If (msgNew.Subject Like "Client Media Report*") Then
            DateYr = Format(Now(), "yyyy", vbUseSystemDayOfWeek, vbUseSystem)
            DateMonth = Format(Now(), "mm. mmmm", vbUseSystemDayOfWeek, vbUseSystem)

            On Error Resume Next
            MkDir "M:\AutoArchive\Client Media Report\" & DateYr
            On Error GoTo 0
            msgNew.SaveAs "M:\AutoArchive\Client Media Report\" & DateYr & "\" & DateMonth & ".msg"
        End If
    End If
End Sub

I'd expect this to save a new email into the correct folder. Eg, the example would save into M:\\AutoArchive\\Client Media Report\\2019\\08. August M:\\AutoArchive\\Client Media Report\\2019\\08. August

It doesn't save and doesn't spit an error.

Example subject line: Client Media Report 05 August 2019

Example file location: M:\\AutoArchive\\Client Media Report\\2019\\08. August M:\\AutoArchive\\Client Media Report\\2019\\08. August

EDIT: Updated with latest code, event triggers error

Unable to open item

on

Set mai = Application.Session.GetItemFromID(strEntryId)

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    MsgBox ("Test1")

    Dim mai As Object
    Dim msgNew As MailItem
    Dim DateYr As Object
    Dim DateMonth As Object

    Set mai = Application.Session.GetItemFromID(strEntryId)
    MsgBox mai.Subject

    If mai.Class = olMail Then
    Set msgNew = objItem
        If (msgNew.Subject Like "DPS Front Pages*") Then
            DateYr = Format(Now(), "yyyy", vbUseSystemDayOfWeek, vbUseSystem)
            DateMonth = Format(Now(), "mm. mmmm", vbUseSystemDayOfWeek, vbUseSystem)

            On Error Resume Next
            MkDir "D:\AutoArchive\Full Front Pages\" & DateYr
            On Error GoTo 0
            msgNew.SaveAs "D:\AutoArchive\Full Front Pages\" & DateYr & "\" & DateMonth & msgNew.Subject & ".msg"
        End If
    End If

End Sub

Answer 1

You need to handle the NewMailEx event of the Application class which is fired when a new item is received in the Inbox.

The NewMailEx event fires when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item. Use this method with caution to minimize the impact on Outlook performance. However, depending on the setup on the client computer, after a new message arrives in the Inbox, processes like spam filtering and client rules that move the new message from the Inbox to another folder can occur asynchronously.

Private Sub NewMailEx(ByVal EntryIDCollection As String)
    Dim mai As Object
    Dim msgNew As MailItem
    Dim DateYr As Object
    Dim DateMonth As Object

    Set mai = Application.Session.GetItemFromID(strEntryId)
    MsgBox mai.Subject

    If mai.Class = olMail Then
    Set msgNew = objItem
    If (msgNew.Subject Like "Client Media Report*") Then
            DateYr = Format(Now(), "yyyy", vbUseSystemDayOfWeek, vbUseSystem)
            DateMonth = Format(Now(), "mm. mmmm", vbUseSystemDayOfWeek, vbUseSystem)

            On Error Resume Next
            MkDir "M:\AutoArchive\Client Media Report\" & DateYr
            On Error GoTo 0
            msgNew.SaveAs "M:\AutoArchive\Client Media Report\" & DateYr & "\" & DateMonth & msgNew.Subject & ".msg"
        End If
    End If

End Sub