Custom VBA to sort emails into folders

aorox

Member
Outlook version
Outlook 2016 64 bit
Email Account
Outlook.com (as MS Exchange)
Hey there... am new here :)

I am trying to make a VBA which can automatically download emails (and their attachments) to certain folders based on a word or code mentioned in the email. For example, I have a folder on my harddrive located at "C:\Uni-Work-2019\2259\Emails", and receive a lot of emails for an assessment which is referred to as '2259'. Everyone in the group uses the number either in the subject line or on the first line of every email. I have another folder "C:\Uni-Work-2019\2260\Emails", etc. I am trying to make a VBA to download everything into those specific folders, however I am finding this quite difficult though as I have no programming experience, and am just trying to follow along with You Tube guides... :(

From what I've read on the internet and watched on You Tube, I came up with the following, but not too sure why it's not working. Any tips would be highly appreciated. Please note I am not posting this expecting someone to write the code for me - I do also want to learn how it's done myself :p

Code:
Private WithEvents InboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub
 
Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\C:\Uni-Work-2019\2259\Emails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "")
xMailItem.SaveAs xFilePath & "\" & xFileName & ".html", olHTML
End If
 Set Atts = Item.Attachments
 
    If Atts.Count > 0 Then
       For Each Att In Atts
           If InStr(LCase(Att.FileName), "2259") > 0 Then
              strPath = "C:\Uni-Work-2019\2259\Emails"
              strName = NewMail.Subject & " " & Chr(45) & " " & Att.FileName
              Att.SaveAsFile strPath & strName
           End If
       Next
    End If
Exit Sub
End Sub
Kind regards,
 
Top