A macro to create folders in Outlook: for specific emails

In this short article we will show you an example of a problem related with creating folders with a macro in Outlook. This will allow you to create folder and fill it with relevant emails.

Example

You receive emails that have a "word" in the title of the email in the format of issue-xxxx, where xxxx is a 4 digit number.

You create a mailbox folder called issues and what you would like the MACRO to do is to find all emails with a string of the format issue-xxxx in the title and look for a folder under issues with that same name. If one is not found, then it should be created. The email should then be moved to that subfolder.

Solution

File projects in their own subfolders:

• Searches subject for a M or Z project number (must be between 4-6 digits).
• Files them in a project subfolder (create folder if one does not exist).

Here is the code:

Dim WithEvents objInboxItems As Outlook.Items  
Dim objDestinationFolder As Outlook.MAPIFolder  
Sub Application_Startup()  
Dim objNameSpace As Outlook.NameSpace  
Dim objInboxFolder As Outlook.MAPIFolder  
Set objNameSpace = Application.Session  
Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)  
Set objInboxItems = objInboxFolder.Items  
Set objDestinationFolder = objInboxFolder.Parent.Folders("Projects")  
End Sub  
' Run this code to stop your rule.  
Sub StopRule()  
Set objInboxItems = Nothing  
End Sub  
' This code is the actual rule.  
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)  
Dim objProjectFolder As Outlook.MAPIFolder  
Dim folderName As String  
Set objRegEx = CreateObject("VBScript.RegExp")  
objRegEx.Global = False  
' Search for email subjects that contains project number (M007439, Z6312)  
objRegEx.Pattern = "([M,Z,P,R,#]d{4,6})"  
Set colMatches = objRegEx.Execute(Item.Subject)  
If colMatches.Count > 0 Then  
For Each myMatch In colMatches  
If Left$(myMatch.Value, 1) = "#" Then  
folderName = "M" & Right$("00" & Mid$(myMatch.Value, 2), 6)  
Else  
folderName = Left$(myMatch.Value, 1) & Right$("00" & Mid$(myMatch.Value, 2), 6)  
End If  
If FolderExists(objDestinationFolder, folderName) Then  
Set objProjectFolder = objDestinationFolder.Folders(folderName)  
Else  
Set objProjectFolder = objDestinationFolder.Folders.Add(folderName)  
End If  
Item.Move objProjectFolder  
Next  
End If  
Set objProjectFolder = Nothing  
End Sub  
Function FolderExists(parentFolder As MAPIFolder, folderName As String)  
Dim tmpInbox As MAPIFolder  
On Error GoTo handleError  
' If the folder doesn't exist, there will be an error in the next  
' line. That error will cause the error handler to go to :handleError  
' and skip the True return value  
Set tmpInbox = parentFolder.Folders(folderName)  
FolderExists = True  
Exit Function  
handleError:  
FolderExists = False  
End Function