Many organizations use shared Exchange mailboxes for support and general information email addresses and assign the responsibility to answer the inquiries to a small group of users. To help even the workload, some managers want to assign the messages to users as they arrive, round-robin style, so each user gets the same number of messages.
It's actually fairly easy to do: count the messages and use Select Case to assign a message to a person.
In these examples, I'm using an ItemAdd macro because it can watch any folder in your profile for new messages, whereas a rule only watches your account's Inbox. Outlook needs to be open to use a macro and if you are moving messages to folders in other mailboxes, the mailboxes need to be in your profile (as a shared mailbox is fine). Because the Inbox is not the default Inbox in your profile, you'll need to use the GetFolderPath macro at the end of this page.
These macros start when Outlook starts; to kickstart the macros during testing, click in the Application_Startup macro and click Run.
To watch a folder in the default mailbox in a profile, use the following line in the Application Startup macro.
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
At the top of ThisOutlookSession, add this code and add the GetFolderPath function (found at the end of this article) to a new Module. Note: if you are watching for new messages in your default mailbox and are not moving the messages to folders in another mailbox or data file, you don't need the GetFolderPath function.
Dim i As Long Private WithEvents olInboxItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.Session Set olInboxItems = GetFolderPath("Shared mailbox name\Inbox").Items Set objNS = Nothing End Sub
Next, copy one of the ItemAdd macros below and paste it under the End Sub line in the Application_Startup macro.
Assign Categories "Round Robin" style
Use the name of the mailbox as it appears in your folder list.
Private Sub olInboxItems_ItemAdd(ByVal Item As Object) Dim strCat As String If Item.Class = olMail Then Select Case i Case 0 strCat = "Case 0" Case 1 strCat = "Case 1" Case 2 strCat = "Case 2" Case 3 strCat = "Case 3" Case 4 strCat = "Case 4" End Select Item.categories = strCat Item.Save Err.Clear End If i = i + 1 Debug.Print i If i = 5 Then i = 0 End Sub
Move Messages to Folders
In this example, I'm moving messages to a folder in the mailbox that is under the Inbox. (The messages in this screenshot were assigned the Case 0 category using the previous macro.)
If the folder is at the same level as the Inbox, use this line instead:
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders(moveFolder)
Private Sub olInboxItems_ItemAdd(ByVal Item As Object) Dim objDestFolder As Outlook.MAPIFolder Dim moveFolder As String If Item.Class = olMail Then Select Case i Case 0 moveFolder = "Folder01" Case 1 moveFolder = "Folder05" Case 2 moveFolder = "Folder10" Case 3 moveFolder = "Folder12" Case 4 moveFolder = "Folder14" End Select Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Folders(moveFolder) Item.Move objDestFolder End If Err.Clear i = i + 1 Debug.Print i If i = 5 Then i = 0 Set objDestFolder = Nothing End Sub
Move Messages to Other Mailboxes
In this example, I'm moving messages to each person's Inbox. To do this, I need the mailboxes in my profile as secondary mailboxes.
Private Sub olInboxItems_ItemAdd(ByVal Item As Object) Dim objDestFolder As Outlook.MAPIFolder Dim moveFolder As String If Item.Class = olMail Then Select Case i Case 0 moveFolder = "Mary Contrary\Inbox" Case 1 moveFolder = "Diane Poremsky\Inbox" Case 2 moveFolder = "John Smith\Inbox" Case 3 moveFolder = "Mark Jackson\Inbox" Case 4 moveFolder = "Sue Ellen\Inbox" End Select Set objDestFolder = GetFolderPath(moveFolder) Item.Move objDestFolder End If Err.Clear i = i + 1 Debug.Print i If i = 5 Then i = 0 Set objDestFolder = Nothing End Sub
If you prefer to forward messages, you'll use this code. The address in the sendTo variable can either be the users Exchange alias or their SMTP email address. Change oForward.Display to oForward.Send to send the messages automatically.
Private Sub olInboxItems_ItemAdd(ByVal Item As Object) Dim sendTo As String Dim oForward As MailItem Dim recip As Recipient If Item.Class = olMail Then Select Case i Case 0 sendTo = "billys" Case 1 sendTo = "johnj" Case 2 sendTo = "dianep" Case 3 sendTo = "maryc" Case 4 sendTo = "email@example.com" End Select Set oForward = Item.Forward Set recip = oForward.recipients.Add(sendTo) recip.Resolve oForward.Display 'send End If Err.Clear i = i + 1 Debug.Print i If i = 5 Then i = 0 Set recip = nothing End Sub
You need to use this function if the mailbox you are watching or that you are moving messages into is not the default mailbox in the profile.
' Use the GetFolderPath function to find a folder in non-default mailboxes Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder Dim oFolder As Outlook.folder Dim FoldersArray As Variant Dim i As Integer On Error GoTo GetFolderPath_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If 'Convert folderpath to array FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.Item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPath = Nothing End If Next End If 'Return the oFolder Set GetFolderPath = oFolder Exit Function GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function
How to use these Macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s 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.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To use the macro code in ThisOutlookSession:
- Expand Project1 and double click on ThisOutlookSession.
- Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)
- Right-click on Project1 and choose New > Module
- Paste GetFolderPath in this Module
More information as well as screenshots are at How to use the VBA Editor