Handling Multiple Inboxes

Posted January 7, 2009 – 9:47 am by JP in Outlook, VBA

Hello! If you are new here, you might want to subscribe to the RSS feed to read the latest articles from this blog.

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.