Organizing Your E-mail Using Custom Item Context Menus in Outlook 2007
Today was my first day back from vacation, a day that I almost always dedicate to trying to clean up my Inbox. I've been meaning to write some VBA to help expedite moving e-mails to common folders, and this was the perfect opportunity. Until Outlook 2007, there was no way to customize any of the right-click context menus that are available throughout the application. No there are six different context menus that can be customized for various objects:
- Attachment
- Folder
- Item
- Shortcut
- Store
- View
The one I'm interested in is the Item menu, which is exposed via the Application.ItemContextMenuDisplay event. I think this is a perfect spot to add menu items for specific folders which I commonly move e-mails into. So that this:
Becomes this:
(the "PERMANENTLY DELETE" item is put in a special location with a new group at the end just for my purposes)
Okay, so let's start coding. First thing - create a clsCustomContextMenus class in the VBA editor. We'll come back to this, but after that go to your ThisOutlookSession module and make sure this code is there:
Option Explicit
Private myCustomContextMenus As clsCustomContextMenus
Private Sub Application_Quit()
Set myCustomContextMenus = Nothing
End Sub
Private Sub Application_Startup()
Set myCustomContextMenus = New clsCustomContextMenus
End Sub
Now we'll populate the clsCustomContextMenus class with the code we need:
Option Explicit
Private WithEvents objOL As Outlook.Application
Private WithEvents objMoveToProjectsFolderButton As Office.CommandBarButton
Private WithEvents objMoveToBlogFolderButton As Office.CommandBarButton
Private WithEvents objMoveToNewslettersFolderButton As Office.CommandBarButton
Private WithEvents objMoveToLowPriorityFolderButton As Office.CommandBarButton
Private WithEvents objMoveToPermanentlyDeleteFolderButton As Office.CommandBarButton
Dim objProjectsFolder As Outlook.Folder
Dim objLowPriorityFolder As Outlook.Folder
Dim objNewslettersFolder As Outlook.Folder
Dim objBlogFolder As Outlook.Folder
Dim objPermanentlyDeleteFolder As Outlook.Folder
Dim objNS As Outlook.NameSpace
Const cProjectsFolderID = "0000000038F2773A1C598D49882D14EC0C5C40C301005097C3A46725204AA35E65B312CAAC8F0000003E109E0000"
Const cLowPriorityFolderID = "0000000038F2773A1C598D49882D14EC0C5C40C301003782A90F9FC7524AA3B8E8C77AB3BE96000047B000480000"
Const cNewslettersFolderID = "000000002DED2EC700EAE74CA42C80F93B65945A02830000"
Const cBlogFolderID = "000000002DED2EC700EAE74CA42C80F93B65945AA2800000"
Const cPermanentlyDelete = "0000000038F2773A1C598D49882D14EC0C5C40C301005097C3A46725204AA35E65B312CAAC8F0000003E3D100000"
Private Sub Class_Initialize()
On Error GoTo Class_Initialize_Error
Set objOL = Outlook.Application
Set objNS = objOL.GetNamespace("MAPI")
Set objProjectsFolder = objNS.GetFolderFromID(cProjectsFolderID)
Set objNewslettersFolder = objNS.GetFolderFromID(cNewslettersFolderID)
Set objBlogFolder = objNS.GetFolderFromID(cBlogFolderID)
Set objLowPriorityFolder = objNS.GetFolderFromID(cLowPriorityFolderID)
Set objPermanentlyDeleteFolder = objNS.GetFolderFromID(cPermanentlyDelete)
On Error GoTo 0
Exit Sub
Class_Initialize_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Class_Initialize of Class Module clsCustomContextMenus"
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set objOL = Nothing
Set objNS = Nothing
Set objMoveToProjectsFolderButton = Nothing
Set objMoveToBlogFolderButton = Nothing
Set objMoveToLowPriorityFolderButton = Nothing
Set objMoveToNewslettersFolderButton = Nothing
Set objMoveToProjectsFolderButton = Nothing
Set objProjectsFolder = Nothing
Set objBlogFolder = Nothing
Set objLowPriorityFolder = Nothing
Set objNewslettersFolder = Nothing
Set objPermanentlyDeleteFolder = Nothing
End Sub
Private Sub objMoveToBlogFolderButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
MoveToFolder objBlogFolder
End Sub
Private Sub objMoveToLowPriorityFolderButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
MoveToFolder objLowPriorityFolder
End Sub
Private Sub objMoveToNewslettersFolderButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
MoveToFolder objNewslettersFolder
End Sub
Private Sub objMoveToPermanentlyDeleteFolderButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
MoveToFolder objPermanentlyDeleteFolder
End Sub
Private Sub objMoveToProjectsFolderButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
MoveToFolder objProjectsFolder
End Sub
Sub MoveToFolder(DestFolder As Outlook.Folder)
On Error GoTo MoveToFolder_Error
Dim objItem As Object
For Each objItem In objOL.ActiveExplorer.Selection
objItem.Move DestFolder
Next
Set objItem = Nothing
On Error GoTo 0
Exit Sub
MoveToFolder_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure MoveToFolder of Class Module clsCustomContextMenus"
Resume Next
End Sub
Private Sub objOL_ContextMenuClose(ByVal ContextMenu As OlContextMenu)
On Error GoTo objOL_ContextMenuClose_Error
Select Case ContextMenu
Case olItemContextMenu
Set objMoveToProjectsFolderButton = Nothing
Set objMoveToBlogFolderButton = Nothing
Set objMoveToLowPriorityFolderButton = Nothing
Set objMoveToNewslettersFolderButton = Nothing
Set objMoveToPermanentlyDeleteFolderButton = Nothing
End Select
On Error GoTo 0
Exit Sub
objOL_ContextMenuClose_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure objOL_ContextMenuClose of Class Module clsCustomContextMenus"
Resume Next
End Sub
Private Sub objOL_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
On Error GoTo objOL_ItemContextMenuDisplay_Error
Dim objItem As Object
Dim blnFoundItem As Boolean
Dim objCBB As Office.CommandBarButton
For Each objItem In Selection
If objItem.Class = olMail Or objItem.Class = olPost Then
blnFoundItem = True
Exit For
End If
Next
If blnFoundItem = False Then GoTo Exitt:
Set objCBB = CommandBar.Controls.Item(1)
objCBB.BeginGroup = True
Set objCBB = CommandBar.Controls.Add(msoControlButton, , , , True)
objCBB.Style = msoButtonWrapCaption
objCBB.Caption = "Move to PROJECTS Folder"
objCBB.BeginGroup = True
Set objMoveToProjectsFolderButton = objCBB
Set objCBB = CommandBar.Controls.Add(msoControlButton, , , , True)
objCBB.Style = msoButtonWrapCaption
objCBB.Caption = "Move to Low Priority Folder"
Set objMoveToLowPriorityFolderButton = objCBB
Set objCBB = CommandBar.Controls.Add(msoControlButton, , , , True)
objCBB.Style = msoButtonWrapCaption
objCBB.Caption = "Move to Newsletters Folder"
Set objMoveToNewslettersFolderButton = objCBB
Set objCBB = CommandBar.Controls.Add(msoControlButton, , , , True)
objCBB.Style = msoButtonWrapCaption
objCBB.Caption = "Move to Blog Folder"
Set objMoveToBlogFolderButton = objCBB
Set objCBB = CommandBar.Controls.Add(msoControlButton, , , , True)
objCBB.Style = msoButtonWrapCaption
objCBB.Caption = "PERMANENTLY DELETE"
objCBB.BeginGroup = True
Set objMoveToPermanentlyDeleteFolderButton = objCBB
Exitt:
Set objCBB = Nothing
Set objItem = Nothing
On Error GoTo 0
Exit Sub
objOL_ItemContextMenuDisplay_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure objOL_ItemContextMenuDisplay of Class Module clsCustomContextMenus"
End Sub
Private Sub objOL_StoreContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Store As Store)
On Error Resume Next
Dim objCBB As Office.CommandBarButton
Dim objIMAP As Office.CommandBarButton
Dim colRules As Outlook.Rules
Set objCBB = CommandBar.Controls.Item(1)
objCBB.BeginGroup = True
Set objCBB = CommandBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
objCBB.Style = msoButtonWrapCaption
Select Case Store.ExchangeStoreType
Case olPrimaryExchangeMailbox
If Store.IsCachedExchange Then
objCBB.Caption = _
"Exchange .ost location: " & Store.FilePath
Else
objCBB.Caption = "Exchange mailbox: Primary"
End If
Case olExchangeMailbox
objCBB.Caption = "Exchange mailbox: Secondary"
Case olExchangePublicFolder
objCBB.Caption = "Exchange Public Folder Store"
Case Else
If Store.IsDataFileStore Then
objCBB.Caption = _
"Store location: " & Store.FilePath
Else
Set objIMAP = CommandBar.FindControl(, 5595)
If Not objIMAP Is Nothing Then
objCBB.Caption = _
"Store for IMAP account: " & Store.DisplayName
Else
objCBB.Caption = "Unknown store type"
End If
End If
End Select
Set objCBB = CommandBar.Controls.Add( _
Type:=msoControlButton, Before:=2, Temporary:=True)
Set colRules = Store.GetRules
If Err.Number = 0 Then
objCBB.Caption = "Number of rules in store: " & colRules.Count
Else
objCBB.Caption = "This store does not support rules."
End If
Set objCBB = Nothing
Set objIMAP = Nothing
End Sub
The constants you see declared at the top of the class with the wacky strings are the unique folder IDs for the folders we want to move e-mails to. You can easily get these IDs by using Outlook Spy (http://www.dimastr.com/) or with a VBA macro that you run with the folder active in Outlook:
Sub DisplayFolderEntryID()
InputBox "EntryID for folder '" & Application.ActiveExplorer.CurrentFolder.Name & "' = ", "SHOW ENTRYID", Application.ActiveExplorer.CurrentFolder.EntryID
End Sub
Note also that we need to declare CommandBarButton objects - one for each folder, and a Folder object of course for each one. The _Click event that is fired for each menu item will pass the appropriate Folder object to the MoveToFolder procedure, which will loop through each selected message and move it to the destination folder. For the ItemContextMenuDisplay event, I'm also checking to make sure that at least one of the selected items is a MailItem or PostItem object. If none of these item types are present, none of the messages will be moved at all. You can of course change this to suit your purposes.
As a bonus, I'm including some sample code from Microsoft Outlook 2007 Programming: Jumpstart for Power Users and Administrators, Sue Mosher's latest book which I was the technical editor for. When you right-click a store's root folder, this code will show the path to the store's .ost or .pst file (it won't display that for IMAP stores). This code is in the StoreContextMenuDisplay event and will generate this when a store is right-clicked:
