Handling Multiple Inboxes

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:

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:

?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:

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:

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:

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).

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.

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.

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.

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.

Related Articles:

• December 3, 2009 -- Save Outlook 2003 E-mail Attachments Automatically
• October 12, 2010 -- Get the Path of any Outlook Item
• February 26, 2010 -- Saving attachments in Outlook