The scenario: You have several email accounts, each with their own data file and you want to empty the deleted items in every data file with one click. If you have one data file in your profile, you could use AutoArchive, but it doesn't work with multiple data files.
The solution: a macro.
When the code runs, each Deleted Items folder in the profile is emptied. The 'Are you sure you want to do this' dialog will come up for each folder unless you disabled the option for Prompt for confirmation before permanently deleting items. It's in File > Options > Advanced. It's in the Other Section at the bottom of the dialog.
To empty the junk email folders, change the folder name to Junk Email.
Note that this will only delete items cached locally. If you use the sync slider to keep less mail on the computer, it won't delete messages still on the server.
This code was tested in Outlook 2013 and Outlook 2016. It should work in Outlook 2010 and Outlook 2007.
Sub EmptyDeletedItems() Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim objExpl As Outlook.Explorer Dim mboxCount As Long Dim i As Long Dim deletedItemsFolder As Outlook.folder Set olApp = Application Set olNS = olApp.GetNamespace("MAPI") Set objExpl = olApp.ActiveExplorer mboxCount = olNS.Folders.Count For i = 1 To mboxCount On Error Resume Next Set deletedItemsFolder = olNS.Folders(i).Folders("Deleted Items") If Err = 0 Then On Error GoTo 0 objExpl.SelectFolder deletedItemsFolder objExpl.CommandBars.ExecuteMso ("EmptyFolder") End If Next i objExpl.SelectFolder olNS.GetDefaultFolder(olFolderInbox) End Sub
Delete Older Items
If you want to delete older Outlook items, add an If statement to check the last modified date, which is the date it was moved to the deleted items folder. It's not the fastest macro, but if you don't have a lot of deleted items to check, it shouldn't be too slow.
This macro deleted items moved to the Deleted items folder 7 days ago.
Sub EmptyDeletedItems() Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim objExpl As Outlook.Explorer Dim mboxCount As Long Dim i As Long Dim deletedItemsFolder As Outlook.Folder Dim objVariant As Variant Set olApp = Application Set olNS = olApp.GetNamespace("MAPI") Set objExpl = olApp.ActiveExplorer mboxCount = olNS.Folders.Count For i = 1 To mboxCount On Error Resume Next Set deletedItemsFolder = olNS.Folders(i).Folders("Deleted Items") If Err = 0 Then On Error GoTo 0 For intCount = deletedItemsFolder.Items.Count To 1 Step -1 Set objVariant = deletedItemsFolder.Items.Item(intCount) DoEvents intDateDiff = DateDiff("d", objVariant.LastModificationTime, Now) ' I'm using 7 days, adjust as needed. If intDateDiff > 7 Then objVariant.Delete End If Next End If Next i objExpl.SelectFolder olNS.GetDefaultFolder(olFolderInbox) End Sub
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, itâs at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
In Outlook 2016 on Windows 10, I get the following run time error executing this macro:
Method 'ExecuteMso' of object '_CommandBars' failed
Any ideas?
If I run the macro while a deleted items folder is selected, it empties that particular folder, but not other deleted items folders. If I have another folder selected such as Inbox, I get the error above