Handling Multiple Inboxes
January 7, 2009 @ 9:47 AM by JP • 1 views • No Comments »
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 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:
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:
' 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:
' 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:
' 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).
' 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 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.
' 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.
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.
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Code Contest: Winners Announcement
Next Post: Excel Tutorial Series Introduction
In my work, I only have one profile, but in addition to my own mailbox, a department mailbox is added to the same profile, so that I can also see what is going on in the department.
I applied most of your code to my Outlook 2003, I expect that when the Department mailbox receives an email, it will send a notification to my own mailbox. So far, it has not worked. And I have no idea, that if the MyDepartmentInbox_ItemAdd event is ever triggered. I set up break point, but nothing happened when I sent an email to my department. Please help. Thank you.
Sorry I take back my previous email. It worked.
I wonder if there is a way to generate a small notification prompt on the right lower corner of the windows, instead of a real email.
You can set up a Rule to display a Desktop Alert when an email meets certain criteria. Or you could add a special keyword to the email you receive, then use a Rule to look for that keyword and show a Desktop Alert. Is that what you needed?
Well, the impression I get from my firm's exchange server administer on Outlook Rules is, they had some bad experiences in an enterprise setting, perhaps it failed to be consistent, or difficult to maintain…when there are so many rules to be managed in an entire firm. So they had tried that before already.
Outlook rules can be client-side as well as server-side. The rules sit on your computer and affect the way emails are received and processed locally. Just go to Tools > Rules and Alerts and set it up.
Outlook appeared to fail to trigger any rule being set up for the secondary departmental email address. Perhaps this is another Outlook 2003 feature. Or I must be missing something.
Actually I'm now quite happy with the single subject line of email notification to one's own mailbox, comparing to the various issues with rules. (My latest attempt on rules failed because there is no more space for my rules on the server…)
A real programming question: Can I use variable to catch my own mailbox, to send email to myself once the department email arrives? Right now, I'm hard coding this way –
with NofifyMsg
.To = "myID@Mycompany.com"
End With
But to deploy to a department of 20-30 word processors, this is lot of very tedeous tasks.
If your email address is unlikely to change, hardcoding might not be that bad. Otherwise you can use
Application.GetNameSpace("MAPI").CurrentUser
and parse it to put together your email address.
Well, the "CurrentUser" property seems to give the Full Name of the account. However, if "Lee, Johnny" is the full name, the email address can be "JxLee@MyCompany.com", where the "x" is the middle Name and is not available in the full name shown by that property. This is exactly happened to me due to possible duplicate account name. So the best way is to get the email box that was originally configured to this account. But I don't know if Outlook 2003 is giving this option or not.
You can be sneaky and create a dummy email and check the SenderEmailAddress Property. That will give you the internet address you need.
The thing is, in this enterprised environment, the security engineer is demanding no Unsigned macro. So I must make it a COM add-in in order to pass the security requirement. But with hard coded user email address, it no longer make sense to do COM add-in, unless it can be fully variable supported.
I'm not sure how you'd code it. Mine got a blank for the SenderEmailAddress property.
See also http://www.outlookcode.com/d/code/getsenderaddy.htm for different methods to get the sender email address.
Thank you for your help. However, the need to click Yes due to the security patch is making this approach not very desirable.
There's no code here that would trigger the security prompt. It's all native Outlook code with all objects being derived from the intrinsic Application object.
Then you must be referring to the Redemption object, correct? If yes, then would distribution of such object to department inside a company, be considered as non-commercial ?
Redemption isn't used here at all.
Redemption is free for personal use only. If you distribute it internally in your organization, it must be purchased. See http://www.dimastr.com/redemption/download.htm for more info.