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
Step 1
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
Step 2
Next, copy one of the ItemAdd macros below and paste it under the End Sub line in the Application_Startup macro.
Assign Categories | Move Messages to Folders
Move Messages to Other Mailboxes | Forward Messages
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 based on sender name
The modification is in response to the question in this Microsoft Community thread, Microsoft Community thread, where the messages are assigned by the sender's name.
We need to get the first letter of the sender's name. The select case statements check to see which case is true and moves the message to a folder. The Case Else handles all messages that do not match the other case statements.
I'm using UCase function to force capitalize the letters, otherwise, someone with a lowercase display name would end up in the Else folder. If you prefer, you can force the sender names to lower case using Left(LCase(Item.SenderName), 1)
, but must also enter the letters in each case statement in lower case.
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 olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items Set objNS = Nothing End Sub Sub olInboxItems_ItemAdd(ByVal Item As Object) Dim objDestFolder As Outlook.MAPIFolder Dim moveFolder As String If Item.Class = olMail Then Debug.Print Item.SenderName, Left(Item.SenderName, 1) Select Case Left(UCase(Item.SenderName), 1) Case "A", "B", "C" moveFolder = "Folder01" Case "D", "E", "F" moveFolder = "Folder02" Case "G", "H", "I" moveFolder = "Folder03" Case Else ' letters not listed above moveFolder = "Folder04" End Select Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Folders(moveFolder) Item.Move objDestFolder End If Err.Clear 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
Forward Messages
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 = "henryp@mydomain.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
GetFolderPath Function
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
Hey Diane, I know this is an old thread, but I was going to see if you could help me. I am using a large combination of your code in two shared inboxes i manage at my job. The issue i am running into is trying to combine multiple round robin statements. So if the subject line has the word "Withdrawal" in it, then assign it to these three people. If the subject has the word deposit in it, assign it to these three people. The issue i am running into is in the below code, when it sees an e-mail with the subject "Withdrawal" it assigns it round robin correctly, but then the one below it, "Deposit" it always assigns it to the first person and the counter does not increase. I have tried everything and can not figure out how to make both counters work. Is there any insight you can give me? If InStr(1, UCase(Item.Subject), UCase("Withdrawal")) Or InStr(1, UCase(Item.Body), UCase("Withdrawal")) <> 0 Then Select Case a Case 0 strCat = "Case 0" Case 1 strCat = "Case 1" End Select Item.Categories = strCat Item.Save Err.Clear End If a = a + 1 Debug.Print a If… Read more »
it looks right... so Debug.Print b always puts a 0 in the immediate window?
Could you post code to run this with a button on all emails in a shared inbox?
I also keep getting an error at line:
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Folders(moveFolder)
I tried using the other code for this line and it also fails. My folders are on the same level as the inbox.
Hi,
This macro works perfectly. How would you modify the macro to skip a folder if you do not want to assign to them or if it is not there without manually changing the macro. I am looking to have a sub folder of "Do Not Assign" that management can move folders into and out of with the code still running and assigning emails to folders under the main inbox folder.
Hi,
This macro works perfectly. How would you modify the macro to skip a folder if you do not want to assign to them or if it is not there without manually changing the macro.
Hi,
I would like to combine 3 of the macros, first to categorize and then to forward the categorized e-mail and then move it to a specified folder. Could you please tell me how to do it?
Thanks,
Cristina
I'm assuming if category 1, then folder 1, and user 1.... you'd merge the select cases and the same with the actions -
Select Case i
Case 0
strCat = "Case 0"
movedFolder = "Folder1"
sendTo = "Billy"
Case 1
......
End Select
Item.categories = strCat
Item.Save
Set oForward = Item.Forward
Set recip = oForward.recipients.Add(sendTo)
recip.Resolve
oForward.Display 'send
Set objDestFolder = GetFolderPath(moveFolder)
Item.Move objDestFolder
End If
Hi Diane, I saw you answered my question in the other post. Thanks for try to help me. I'm sorry for my ignorance, I did not know until recently that there was programming in Outlook, I'm new to it. All I needed was that: When a new email arrives in the shared box, check if the sender is on the Global Contact List, if so, categorize as "Diamond Consultant", if not, classify as "Other Emails". Is there a practical way to do this? I tried accessing the generic email as JMaster and creating the rule but I could not figure out how to access the email key, it asks for a password and no one could tell me what it was, ie it will have to be by macro. The shared email is platform.comercial@diamond.com.br Rule to categorize as Consultant: The sender must be in the "Global Contact List". So categorize as a Consultant Diamond and the color of the category is dark blue. If it does not fit the rule does not do anything, or else, could classify as "Other Emails" and the category color is red. Please please please, help-me to do this. I'm from Brazil, and no Brazilian… Read more »
Hello Thanks for the Macro i used the same it works till the assiging the case post that its stuck at "Set objDesFolder = Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(moveFolder)" the error i get is Object not found. I put the below code in This outlook session. Dim i As Long Private WithEvents olInboxItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.Session Set olInboxItems = GetFolderPath("gl testing\Inbox").Items Set objNS = Nothing End Sub 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 Dim objDestFolder As Outlook.MAPIFolder Dim moveFolder As String If Item.Class = olMail Then Select Case i Case 0 moveFolder = "AV" Case 1 moveFolder = "AJ" Case 2 moveFolder = "AK" Case 3 moveFolder = "BB" Case 4 moveFolder = "SS" End Select Set objDesFolder = Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(moveFolder) Item.Move objDestFolder End If Set objDestFolder = Nothing… Read more »
>> "Set objDesFolder = Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(moveFolder)"
>> the error i get is Object not found.
each moveFolder is at the same level as the Inbox? That is where Outlook expects them. They also need to exist, outlook won't create them.
Hello Diane, Thanks for the response, The folder is under Inbox. and are already existing.
Please see attached screenshot,
Thanks
Abi Jacob
Hi Diane,
I'm creating a Macro to batch assign mail messages in the mailbox to different users. The code you mentioned is for Application start up. Can I use a command button to assign and categorise the mail messages to the users and transfer the outlook data to excel for monitoring?
Yes, you can. The macor needs just a little tweaking. I have a stub macro that could do it with no changes to theat code, but it only runs on the selected message. If you want to run it on all messages in a folder, it needs a little more tweaking.
At the simplest, you just need to change the item, dim the item, and set the item - this will run only on the selected item:
Private Sub AssignMessages()
Dim Item as Mailitem
Dim objDestFolder As Outlook.MAPIFolder
Dim moveFolder As String
Set Item = Application.ActiveExplorer.Selection.Item(1)
Dim objDestFolder As Outlook.MAPIFolder
-- snip--