Handling Multiple Inboxes
Posted January 7, 2009 – 9:47 am by JP in Outlook, VBA
If you have multiple mail profiles set up in Outlook, you might need VBA code that acts on items in several different inboxes (instead of just your own). Typically you'll see this in an environment where Exchange Server is running. Hold on, there's a lot of VBA code in this post!
For example, you might have a profile for your personal emails (you@yourcompany.com), a profile for a project group you're working in (projectgroup@yourcompany.com), and a profile for your department or team (department@yourcompany.com). These are more than just distribution lists; profiles are virtual users whose accounts you can login to, allowing you to send emails from that mailbox as if you were that user.
See Outlook e-mail profiles explained for further information about profiles, and How to create and configure an e-mail profile in Outlook 2007 and Outlook 2003 for information about how to create them (from an end user perspective).
Using the MAPIFolder.Parent Property, we can programmatically determine which profile we are in, and set our object references accordingly. In this example, we have set up three profiles: an end user, a project group and a department (I'll continue with the example I started earlier). The end user has added both of the other profiles to his Outlook installation, but for security reasons the other two profiles can only view themselves. In the ThisOutlookSession module, paste the following:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | Private WithEvents MyInbox As Outlook.Items Private WithEvents MyProjectInbox As Outlook.Items Private WithEvents MyDepartmentInbox As Outlook.Items Private Sub Application_Startup() Dim objNS As Outlook.NameSpace Set objNS = GetNamespace("MAPI") Select Case objNS.GetDefaultFolder(olFolderInbox).Parent Case "Mailbox - Your Name" ' personal profile Set MyInbox = objNS.Folders("Mailbox - Your Name").Folders("Inbox").Items Set MyProjectInbox = objNS.Folders("Mailbox - Project Group"). _ Folders("Inbox").Items Set MyDepartmentInbox = objNS.Folders("Mailbox - Department"). _ Folders("Inbox").Items Case "Mailbox - Project Group" ' project profile Set MyProjectInbox = objNS.Folders("Mailbox - Project Group"). _ Folders("Inbox").Items Case "Mailbox - Department" ' department profile Set MyDepartmentInbox = objNS.Folders("Mailbox - Department"). _ Folders("Inbox").Items End Select End Sub |
As you can see from the code above, the following rules apply:
- If we are in the default Inbox, set object references to the Inboxes for all three profiles to which we have access.
- If we are in either of the other profiles, set an object reference only to its own Inbox.
The mailbox name in quotes above can be found by looking at your folder list and noting the name of the mailbox at the top of the folder hierarchy. As an alternative, login to each profile and run the following code from the immediate window in Outlook's VBIDE:
1 | ?Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent |
We could have used GetDefaultFolder(olFolderInbox) to reference the default Inbox for each profile, but I chose to use Folders("Inbox").Items instead, to demonstrate how to you can directly reference a folder in the hierarchy. Also, it can get confusing to use mixed references, because a reference to MyProjectInbox or MyDepartmentInbox can use GetDefaultFolder if we are logged into the Project profile, but must use Folders("Inbox").Items if we are not. In other words, GetDefaultFolder points to different places depending on the profile we are logged into. Using mixed references increases the chances of error if we accidently cut and paste the wrong code around.
Now it's a simple matter of using the ItemAdd event for each Items Collection reference, so we can perform different actions on each incoming item for each Inbox/profile. Sample code that you might use inside each event follows. Note that ALL the ItemAdd code must be placed in the ThisOutlookSession module in your Outlook VBIDE, even the subs for different profiles.
Event code for end user Inbox:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | Private Sub MyInbox_ItemAdd(ByVal Item As Object) ' code here will run every time we are logged in to our default profile, ' and a new item is received (or placed) in the default Inbox ' for example: ' automatically add a popup reminder (30 mins) if it is missing from an incoming ' meeting request; sometimes people forget to add reminders to their meetings ' code courtesy of Michael Bauer, ' MS Outlook MVP (http://vboffice.net/index.html?lang=en) Dim objNS As Outlook.NameSpace Set objNS = GetNamespace("MAPI") If TypeOf Item Is Outlook.MeetingItem Then If Item.Class = olMeetingRequest Then ' it's not a meeting response Dim Meet As Outlook.MeetingItem Dim Appt As Outlook.AppointmentItem Set Meet = Item With Meet If .ReminderSet = False Then .ReminderSet = True .Save End If End With Set Appt = Meet.GetAssociatedAppointment(True) If Not Appt Is Nothing Then With Appt .ReminderSet = True .ReminderMinutesBeforeStart = 30 .Save End With End If Set Appt = Nothing Set Meet = Nothing End If End If Set objNS = Nothing End Sub |
Event code for Project Group Inbox:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | Private Sub MyProjectInbox_ItemAdd(ByVal Item As Object) ' code here will run every time we are logged in to our default profile OR the ' Project Group, and a new item is received (or placed) in the Inbox for ' that profile ' for example: If TypeOf Item Is Outlook.MailItem Then Dim objNS As Outlook.NameSpace Dim Msg As Outlook.MailItem Dim ReportsFolder As Outlook.MAPIFolder Dim ClosedFolder As Outlook.MAPIFolder Set Msg = Item Set objNS = Outlook.GetNamespace("MAPI") ' some pre-existing folders in our mailbox hierarchy Set ReportsFolder = objNS.Folders("Mailbox - Project Group"). _ Folders("Inbox").Folders("Reports") Set ClosedFolder = objNS.Folders("Mailbox - Project Group"). _ Folders("Inbox").Folders("Dealt With") ' I can drag and drop messages intended for the project group, but sent to my ' personal inbox by mistake, and I don't want Outlook to do anything to them If Msg.To = "Jimmy Pena" Then GoTo ExitProc End If ' move unimportant emails out of the Inbox, mark as read If InStr(Msg.Subject, "Some subject I don't need to read") > 0 Then With Msg .UnRead = False .Move ClosedFolder End With GoTo ExitProc End If ' move status reports If Instr(Msg.Subject, "Project Status Report") > 0 Then With Msg .UnRead = False .Move ReportsFolder End With GoTo ExitProc End If ' move emails from John Smith that come after 6pm or on the weekend If (Msg.SenderName = "John Smith") Then If (Format(Msg.ReceivedTime, "HH:MM") > "18:00") Or _ (Weekday(Msg.ReceivedTime, vbMonday) > 5) Then With Msg .UnRead = False .Move ClosedFolder End With GoTo ExitProc End If End If ' remove HIGH IMPORTANCE FLAG from incoming emails, I hate that With Msg .Importance = olImportanceNormal .Save End With ExitProc: Set ReportsFolder = Nothing Set ClosedFolder = Nothing Set Msg = Nothing Set objNS = Nothing End If End Sub |
Event code for Department Inbox:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | Private Sub MyDepartmentInbox_ItemAdd(ByVal Item As Object) ' code here will run every time we are logged in to our default profile OR the ' Department profile, and a new item is received (or placed) in the Inbox for ' that profile Dim lCount As Long Dim Msg As Outlook.MailItem Dim objNS As Outlook.NameSpace Dim ClosedFolder As Outlook.MAPIFolder Set Msg = Item Set objNS = Outlook.GetNamespace("MAPI") Set ClosedFolder = objNS.Folders("Mailbox - Department").Folders("Inbox"). _ Folders("Dealt With") ' if our department name is not in the To: field, ' move it to the "Dealt With" folder ' I don't know about you, but if I'm not in the To: field, ' I don't read the email lCount = 0 For Each sRecip In Msg.Recipients If InStr(sRecip.Name, "Department Name") > 0 Then If (sRecip.Type = olTo) Then lCount = 1 Exit For End If End If Next sRecip If lCount = 0 Then ' Department was not in the To: field With Msg .UnRead = False .Move ClosedFolder End With GoTo ExitProc End If ExitProc: Set ClosedFolder = Nothing Set Msg = Nothing End Sub |
Here are a couple of utility functions I use in the event code above. If you wanted to run an Excel VBA macro in response to an incoming email (for example, if the email had an attachment), the following function can be called from the subs above. This code will run the named macro on a single xls attachment to an email. If the email has multiple attachments, you'll need to check Attachments.DisplayName for the correct one (and you'll also need to change the code below to run on the correct attachment).
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | Function ProcessFile(MacroName As String, Item As Outlook.MailItem) As Boolean ' runs named macro on a single .xls attachment to an email message ' returns TRUE if successful Dim MyAttachments As Outlook.Attachments Dim XLApp As Excel.Application Dim Att As String Const attPath As String = "C:\" ' create new instance to avoid interfering with any possible ' existing instances On Error Resume Next Set XLApp = CreateObject("Excel.Application") On Error GoTo 0 If XLApp Is Nothing Then ProcessFile = False GoTo ExitProc End If ' save attachment Set MyAttachments = Item.Attachments Att = MyAttachments.Item(1).DisplayName MyAttachments.Item(1).SaveAsFile attPath & Att ' need to open personal workbook? On Error Resume Next XLApp.Workbooks.Open _ ("C:\Users\Jimmy Pena\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS") On Error GoTo 0 ' open workbook and run macro XLApp.Workbooks.Open (attPath & Att) XLApp.Run "PERSONAL.XLS!" & MacroName ' if we got this far, assume success ProcessFile = True ExitProc: On Error Resume Next XLApp.Workbooks.Close Kill attPath & Att XLApp.Quit Set XLApp = Nothing On Error GoTo 0 End Function |
The macro would be called as follows. If the Excel macro runs successfully, the message is moved to the "Dealt With" folder.
1 2 3 4 5 6 7 8 9 | If (Msg.SenderName = "John Smith") And (Msg.Attachments.Count > 0) Then If ProcessFile("My_Excel_Macro_Name", Msg) Then With Msg .UnRead = False .Move ClosedFolder GoTo ExitProc End With End If End If |
This function can be used to send messages in response to events that occur in the code above. For example, if I receive a certain email, or an attachment I expected to receive was missing, this routine will send a message to a specific Inbox (as if it was a new email). This function returns TRUE if the message was successfully sent.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | Function PostMsg(Msg As Outlook.MailItem) As Boolean ' send a message to a specific Inbox ' returns TRUE if successful On Error GoTo ErrorHandler Dim NotifyMsg As Outlook.MailItem Dim NewFolder As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Dim strMsg As String Set objNS = GetNamespace("MAPI") Set NewFolder = objNS.Folders("Mailbox - Department").Folders("Inbox") Set NotifyMsg = NewFolder.Items.Add(olMailItem) With NotifyMsg .Subject = "Important Message Received" .Importance = olImportanceHigh .To = "department@yourcompany.com" strMsg = "The following message was received on " & Msg.ReceivedTime & ":" strMsg = strMsg & vbCr & vbCr & Msg.Body strMsg = strMsg & vbCr & vbCr & "This is an automatically generated message." .Body = strMsg .UnRead = True End With NotifyMsg.Send ' if we got this far, assume success PostMsg = True GoTo ExitProc ErrorHandler: PostMsg = False ExitProc: Set NotifyMsg = Nothing Set objNS = Nothing Set NewFolder = Nothing End Function |
The Application_ItemSend event can be used to sort messages sent from each profile. We can use it to keep each profile's Sent Items separate. Otherwise, they all end up in your default profile's Sent Items folder.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) If TypeName(Item) = "MailItem" Then Dim olApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim Msg As Outlook.MailItem Dim objFolder As Outlook.MAPIFolder Dim FolderName As String Dim sRecip As Outlook.Recipient Set olApp = Outlook.Application Set objNS = olApp.GetNamespace("MAPI") Set Msg = Item ' set appropriate Sent Items Folder, add "Have replies sent to" email address FolderName = objNS.GetDefaultFolder(olFolderInbox).Parent Select Case FolderName Case "Mailbox - Your Name" Set objFolder = objNS.Folders("Mailbox - Your Name").Folders("Sent Items") Msg.ReplyRecipients.Add "you@yourcompany.com" Case "Mailbox - Department" Set objFolder = objNS.Folders("Mailbox - Department").Folders("Sent Items") Msg.ReplyRecipients.Add "department@yourcompany.com" Case "Mailbox - Project Group" Set objFolder = objNS.Folders("Mailbox - Project Group"). _ Folders("Sent Items") Msg.ReplyRecipients.Add "projectgroup@yourcompany.com" End Select Msg.ReplyRecipients.ResolveAll Set Msg.SaveSentMessageFolder = objFolder ' delete self from reply recipients list when Replying To All For Each sRecip In Msg.Recipients If sRecip.Name = "Your Name" Then sRecip.Delete Exit For End If Next sRecip End If ExitProc: Set objFolder = Nothing Set objNS = Nothing Set olApp = Nothing End Sub |
The above code will move the sent message to the correct Sent Items folder, depending on which profile you are logged into. It will also set the "Have replies sent to" option the appropriate email address, to make sure responses go to the correct address. Finally, when Replying to All, delete yourself from the recipient list.
Tags: event code, function, GetDefaultFolder, GetNamespace, ItemAdd, MAPI, parent, profile













Comments RSS

