Outlook VBA macro to auto save an incoming email to local folder based on employee code in subject

My HR department receives hundreds of email daily with employee code in subject line they wanted to save all email to local drive having employee code so that any one can access email offline without providing mail access to whole team..

Their requirement was to read subject line of each email & check for employee code and save email so received employee folder in local drive with same subject line. If there is no folder then new folder to be created automatic, all employee code is like VB12345 & all email to save in C:\EmpPersonal\.

Copy and paste below code in outlook in ThisOutlookSession module:

Public WithEvents olItems As Outlook.Items

Private Sub Application_Startup()

    Dim olApp As Outlook.Application

    Dim objNS As Outlook.NameSpace

    Set olApp = Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")

    Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

    On Error GoTo ErrorHandler

    Dim msg As Outlook.MailItem

    Dim endOfSubject As String

    Dim destFolder As String

    Dim myCode As String

    Dim sName As String

    Dim regEx As Object

    Dim matches



    sName = Item.Subject

    ReplaceCharsForFileName sName, "_"

    If TypeName(Item) = "MailItem" Then

        Set msg = Item

         ' check if subject field contains CODE



        Set regEx = CreateObject("VBScript.RegExp")

        With regEx

            .Pattern = "\w+\d{5}"

            .IgnoreCase = True

            .Global = True

        End With



        If regEx.Test(Item.Subject) Then

           Set matches = regEx.Execute(Item.Subject)

           myCode = matches(0)

        Else

           Exit Sub

        End If



        destFolder = "C:/EmpPersonal/"

        destFolder = destFolder & myCode

        ' if subfolder doesn't exist, create it

        If Dir(destFolder, vbDirectory) = "" Then

           MkDir destFolder

        End If

        ' Copy msg to local folder

        Item.SaveAs destFolder & "/" & sName & ".msg", olMSG

    End If

ProgramExit:

    Exit Sub

ErrorHandler:

    MsgBox Err.Number & " - " & Err.Description

    Resume ProgramExit

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

Do post your feedback on this.....

Cheers!!