Automate move of read email to another folder

Over the last six months I have been investing a bit of time every now and again to improve my working methods. If I can do things better and faster then I can start doing better things with my time. Today I wanted to write up one of them, a way to save me much time and frustration each day processing email.

The solution was to write a macro to go off and file emails I have read into my mail folder tree. The key is that its dynamic and works out where to put messages based on the sender. Sweet.

Some background. Everyone has a different method of handling their email. Some people think they have no method, that just means they have a bad one. My method is that an email stays in my email box until its processed and can go to archive. I try to use a GTD method so most don't stay there for that long. The exception to this rule is I do have a folder under my Inbox called Process, where I move messages that just need some mindless activity that I must do at some stage, I troll this folder every few days when I have a short period of time to kill.

Now I also never delete emails unless they are really spam, advertising or addressed wrong, its amazing how that email you never thought important becomes critical after six months. Many people are like me and file mail away in folders that categorise them. A folder tree works great and anables you to filter mail and perform searches. I have folders for each of the companies that I deal with and for colleagues. This method was great back in the day when the search function in Outlook was slow and painful, it really helped to speed things up.

However I find I spend a lot of time filing messages, there are probably 80 or so folders and even though there are a few speed tricks for moving messages they never really make it truly effective. As you get more and more messages a day that need a scan and file, this time really adds up.

I figured there are three possible solutions to the problem.

• First you could pre-filter messages using Outlook rules. Many people do this, but to find messages you need to walk the tree and look for unread ones, or use the new search function to list all unread messages. Thats all too messy and will not work great when working between my Blackberry and Outlook.
• The second option is to just dump everything into a very small set of folders, then use search to categorise. This is close but I am not ready to give up my folder structure just yet.
• The last option is to automate it. I figured it was a common task and should be simple.

There are quite a few example Macros on the Internet for moving an email to another folder. Most don't work and none were dynamic. So here is what the Macro I wrote does.

Take the selected message and determine a destination folder name based on the sender. Walk the Mail folder tree and find a folder that matches the destination folder name, mark the message as read and move it there. To determine the destination folder name I use two methods. If its an Exchange message I use the first and last name combination. If its an SMTP message, that is external, I pull the domain name. Some external messages I actually want to file by name, so I have it use the first and last name instead for those specific domains.

Now all I need to do is make sure there is a folder somewhere within my tree that matches the domain name or the user name. If it can't find a match the message just stays in the Inbox. It works great!

I created a button with a keyboard shortcut so now as I read my Inbox, if I don't need to do anything further on a message I just hit Alt-X and it disappears into the folder tree. The first email from a company or internal person I just create a folder wherever is appropriate in my folder tree. So for the domain name filed messages I create parent folders that group them, for example Customers and Suppliers. I can move the folders around and it all still works.

Here is the code as it stands today.

Sub FileMessage()

  Const olFolderInbox = 6
 Dim objItem As Outlook.MailItem
 Dim objMailbox As Outlook.MAPIFolder
 Dim FolderToSendTo As String


 Set objOutlook = CreateObject("Outlook.Application")
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)

 strFolderName = objInbox.Parent
 Set objMailbox = objNamespace.folders(strFolderName)

 Set colItems = objInbox.Items

 If objOutlook.ActiveExplorer.Selection.Count = 0 Then
     'Require that this procedure be called only when a message is selected
     Exit Sub
 End If

 For Each objItem In objOutlook.ActiveExplorer.Selection
         If objItem.Class = olMail Then
             ' SenderEmailType is "EX" or "SMTP"
             ' SenderEmailAddress
             ' SenderName
             FolderToSendTo = ""
             If objItem.SenderEmailType = "SMTP" Then
              
                 ' Lets determine the domain name to file in under
                 atLoc = InStr(objItem.SenderEmailAddress, "@")
                 DomainName = Right(objItem.SenderEmailAddress, Len(objItem.SenderEmailAddress) - atLoc)
              
              
                 If LCase(DomainName) = "vmware.com" Then
                     DomainName = Left(objItem.SenderEmailAddress, atLoc - 1)
                     DomainName = Replace(DomainName, ".", " ") ' Replace dots with spaces
                     DomainName = Replace(DomainName, "'", "") ' Replace quotes with nothing
                 End If
                 FolderToSendTo = DomainName
              
             ElseIf objItem.SenderEmailType = "EX" Then
            
                 'MsgBox objItem.SenderName, vbOKOnly + vbExclamation, "INFO"
                 FolderToSendTo = objItem.SenderName
              
             Else
                 MsgBox "Don't know what to do, unknown SenderEmailType (not EX or SMTP)", vbOKOnly + vbExclamation, " OPPS"
                 Exit Sub
             End If
          
                 ' MsgBox "Will look for folder " + FolderToSendTo, vbOKOnly, "INFO"
                 FindFolder objMailbox, objItem, FolderToSendTo
         End If
 Next

 Set objItem = Nothing
 Set objFolder = Nothing
 Set objInbox = Nothing
 Set objNS = Nothing
End Sub

Sub FindFolder(oFolder As Outlook.MAPIFolder, theMessage As Outlook.MailItem, theFolderToFind)
 Dim folders As Outlook.MAPIFolder
 Dim iFolder As Outlook.MAPIFolder
 Dim foldercount As Integer
  
 Set theFolders = oFolder.folders
 foldercount = theFolders.Count
 'Check if there are any folders below oFolder
 If foldercount Then
     For Each iFolder In theFolders
         If theFolderToFind <> "" Then
             ' Debug.Print iFolder.FolderPath + " ^ " + theFolderToFind
             If InStr(LCase(iFolder.FolderPath), "\" + LCase(theFolderToFind)) Then
                 ' Move it to the final location!
                 theMessage.UnRead = False
                 theMessage.Move iFolder
                 theFolderToFind = ""
             Else
                 FindFolder iFolder, theMessage, theFolderToFind
             End If
         End If
         Next
 End If
End Sub

I have not done any programming for years (after doing it for the first 10 years of my career), so this was a fun exercise. There are a few tweaks I am thinking of making. But this should give people a good starting place. If I make any big changes I will update the code here.

You could go to town on algorithms on which folder to put messages in, that can be left as an exercise for the reader. If you come up with anything interesting or find this useful post in the comments.

Rodos