0
Thanks

A few words of thanks would be greatly appreciated.

Outlook - A macro to create folders

In this short article we will show you an example of a problem related with creating folders with a MACRO in Outlook.

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

Image: © Unsplash

0
Thanks

A few words of thanks would be greatly appreciated.

Ask a question
CCM is a leading international tech website. Our content is written in collaboration with IT experts, under the direction of Jean-François Pillou, founder of CCM.net. CCM reaches more than 50 million unique visitors per month and is available in 11 languages.
Related
This document, titled « Outlook - A macro to create folders », is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!