Create an Outlook rule to create folders, if necessary, based on the text in the subject line

Question

I am looking for a clear way to use vba to read email subject lines upon receipt, to create a new folder or just use an existing folder to move email. I have seen some vba examples, but none address the new mail methods found in the vba editor with Outlook.

Answer 1

Refuse this article , in particular, methods 2 and 3, I think this will point you in the right direction.

Answer 2

I wrote code for this. My macro searches for emails for a specific line, and then takes everything after that and creates a folder using that name. You will need several functions: 1) Check if the folder exists 2) Create it if it is not 3) Move MailItem to a new folder 4) Call these functions

NOTE. Most of this code is hard-coded and can be modified to enter the user if necessary. In addition, it will not work for subfolders (you will have to configure it).

1) Check the folder:

Function CheckForFolder(strFolder As String) As Boolean Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim olInbox As Outlook.MAPIFolder Dim FolderToCheck As Outlook.MAPIFolder Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set olInbox = olNS.GetDefaultFolder(olFolderInbox) On Error Resume Next Set FolderToCheck = olInbox.Folders(strFolder) On Error GoTo 0 If Not FolderToCheck Is Nothing Then CheckForFolder = True End If ExitProc: Set FolderToCheck = Nothing Set olInbox = Nothing Set olNS = Nothing Set olApp = Nothing End Function 

2) Create:

 Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim olInbox As Outlook.MAPIFolder Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set olInbox = olNS.GetDefaultFolder(olFolderInbox) Set CreateSubFolder = olInbox.Folders.Add(strFolder) ExitProc: Set olInbox = Nothing Set olNS = Nothing Set olApp = Nothing End Function 

3) Search and move:

 Function SearchAndMove(lookFor As String) Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim olInbox As Outlook.MAPIFolder Dim FolderToCheck As Outlook.MAPIFolder Dim myItem As Object Dim MyFolder As Outlook.MAPIFolder Dim lookIn As String Dim newName As String Dim location As Integer Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set olInbox = olNS.GetDefaultFolder(olFolderInbox) For Each myItem In olInbox.Items lookIn = myItem.Subject If InStr(lookIn, lookFor) Then location = InStr(lookIn, lookFor) newName = Mid(lookIn, location) If CheckForFolder(newName) = False Then Set MyFolder = CreateSubFolder(newName) myItem.Move MyFolder Else Set MyFolder = olInbox.Folders(newName) myItem.Move MyFolder End If End If Next myItem End Function 

4) call function:

 Sub myMacro() Dim str as String str = "Thing to look for in the subjectline" SearchAndMove (str) End Sub