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:
1 |
Option Explicit |
1 |
Private myCustomContextMenus As clsCustomContextMenus |
1 |
Private Sub Application_Quit() |
1 |
Set myCustomContextMenus = Nothing |
1 |
End Sub |
1 |
Private Sub Application_Startup() |
1 |
Set myCustomContextMenus = New clsCustomContextMenus |
1 |
End Sub |
Now we’ll populate the clsCustomContextMenus class with the code we need:
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 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
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:
You must log in to post a comment.