VBA: File messages by client code

The problem: a user needs to file messages from clients in a specific folder, which is the clients accounts number. Moving the messages manually is time consuming but using a macro makes it easy.

This macro, as written, watches the Inbox and Sent folder and moves all messages containing the client id to a folder of the same name (as written, the client folders are at the same level as the Inbox).

To use a different folder, change this line:

 Set Folder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Clients")

For a path under public folder, use this format:

Set Folder = Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Shared Folders").Folders("Clients")

If the folder does not exist, the macro won't move the message.

Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private WithEvents objSentItems As Outlook.Items
Dim strCode As String
Dim Code As String

Private m_Folder As Outlook.MAPIFolder
Private m_Find As String

' False is slower but does not lock outlook up
' True is faster but outlook may not respond
Private Const SpeedUp As Boolean = False

Private Sub Application_Startup()

Dim objInboxFolder As Outlook.Folder
Dim objSentFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")

'Set the folder and items to watch:
Set objInboxFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objItems = objInboxFolder.Items

Set objSentFolder = objNS.GetDefaultFolder(olFolderSentMail)
Set objSentItems = objSentFolder.Items

Set objSentFolder = Nothing
Set objInboxFolder = Nothing
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
If Item.Class = olMail Then
    MoveMessages Item
End If
End Sub

Private Sub objSentItems_ItemAdd(ByVal Item As Object)
If Item.Class = olMail Then
    MoveMessages Item
End If
End Sub

Public Sub MoveMessages(ByVal Item As MailItem)
Dim strText As String
'' find the code
strText = Item.Subject & vbCrLf & Item.Body
strCode = ExtractText(strText)
If strCode = "" Then
    Exit Sub
End If

' if the code is in the message, find the folder
' move message
    FindFolder
    On Error Resume Next
    Item.Move m_Folder
      If m_Folder Is Nothing Then
        Exit Sub
      End If

Err.Clear
End Sub

Function ExtractText(Str As String) ' As String
Dim regEx As New RegExp
Dim NumMatches As MatchCollection
Dim M As Match

'this pattern looks for 6 digits in the subject
With regEx
    .Pattern = "(AB[0-9]{6})"
    .IgnoreCase = True
    .Global = False
End With

Set NumMatches = regEx.Execute(Str)
If NumMatches.Count = 0 Then
      ExtractText = ""
Else
Set M = NumMatches(0)
  ExtractText = M.SubMatches(0)
End If
Code = ExtractText
End Function

' Borrowing Michael's code from
' http://vboffice.net/en/developers/find-folder-by-name

Public Sub FindFolder()
  Dim Name$
  Dim Folders As Outlook.Folders
  Dim Folder As Outlook.MAPIFolder

  Set m_Folder = Nothing
  m_Find = ""

  Name = "*" & strCode
  If Len(Trim$(Name)) = 0 Then Exit Sub
  m_Find = Name

  m_Find = LCase$(m_Find)

  Set Folder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Clients")
  LoopFolders Folder.Folders

End Sub

Private Sub LoopFolders(Folders As Outlook.Folders)
  Dim Folder As Outlook.MAPIFolder
  Dim F As Outlook.MAPIFolder
  Dim Found As Boolean
  
  If SpeedUp = False Then DoEvents

  For Each F In Folders
      Found = (LCase$(F.Name) Like m_Find)

    If Found Then
      Set m_Folder = F
      Exit For
    Else
      LoopFolders F.Folders
      If Not m_Folder Is Nothing Then Exit For
    End If
  Next
End Sub

Moving a copy

Moving a copy is difficult when you are using an ItemAdd macro as any new item added to the folder is processed by the macro and making a copy is a new item. The macro goes into a loop and hangs.

We can use an If statement to look for a value, or compare a field to a value, which we set before making the copy. If the value is set, Outlook will skip it. Comparing the subject to the previous message subject, adding categories, marking the message as read, setting a flag or another value will work.

In the first example, I'm checking the subject to see if it matches the last subject. If so, the message is not processed. The advantage is that the message isn't edited in any way. The disadvantage is that if you receive two messages back to back with the same subject, only the first will be processed.

To use this method, you'll change the ItemAdd macros to check for the subject and add the copy code to the move messages macro.

Private Sub objItems_ItemAdd(ByVal Item As Object)
If Not Not Item.Class = olMail And Item.Subject <> strSubject Then
strSubject = Item.Subject
    MoveMessages Item
End If
End Sub

Replace the If block the MoveMessages macro with the following:

If m_Folder Is Nothing Then
  Exit Sub
 Else
Dim objCopy
Set objCopy = Item.Copy
Item.Move m_Folder
End If

In this example, I'm setting a flag on new messages before creating a copy. In the ItemAdd macro, we check to see if there is a flag set. If not, a flag is set, the message is copied and moved.

While this will work when multiple messages with the same subject arrive in quick succession, both copies will be flagged or tagged.

Private Sub objItems_ItemAdd(ByVal Item As Object)
If Not Not Item.Class = olMail And Not Item.IsMarkedAsTask Then
    MoveMessages Item
End If
End Sub

Replace the If block the MoveMessages macro with the following:

    
Item.MarkAsTask olMarkThisWeek

If m_Folder Is Nothing Then
  Exit Sub
    Else

Dim objCopy
Set objCopy = Item.Copy
Item.Move m_Folder
End If

How to use the macros on this page

First: You need to have macro security set to the lowest setting, Enable all macros during testing. The macros will not work with the top two options that disable all macros or unsigned macros. You could choose the option Notification for all macros, then accept it each time you restart Outlook, however, because it's somewhat hard to sneak macros into Outlook (unlike in Word and Excel), allowing all macros is safe, especially during the testing phase. You can sign the macro when it is finished and change the macro security to notify.

To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Macros that run when Outlook starts or automatically need to be in ThisOutlookSession, all other macros should be put in a module, but most will also work if placed in ThisOutlookSession. (It's generally recommended to keep only the automatic macros in ThisOutlookSession and use modules for all other macros.) The instructions are below.

The macros on this page need to go into ThisOutlookSession.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the macro code in ThisOutlookSession:

1. Expand Project1 and double click on ThisOutlookSession.
2. Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)

Set a reference to other Object Libraries
If you receive a "User-defined type not defined" error, you need to set a reference to another object library. For this macro, it is the VBScript Regular Expression library.

1. Go to Tools, References menu.
2. Locate the object library in the list and add a check mark to it.
   

More information as well as screenshots are at How to use the VBA Editor