MikeSel

I was recently spotted an opportunity to flex my VBA muscles when Richard Tubb posted a tweet, asking for solutions on how to clear out unused Microsoft Outlook folders.

I decided to accept the challenge, and threw together the following VBA Sub

'****************************************************************************************
'****************************************************************************************
'******
'****** Name: Purge empty outlook mail folders
'****** Description: Search Outlook Inbox subfolders and remove any unused
'****** Date: 30/12/2010
'****** Author: Mike Hudson - http://www.mikesel.info
'******
'****************************************************************************************
'****************************************************************************************
Public Sub FolderPurge()
Dim myToplvl As Folders 'Declare top level folder object
Dim myFldr As Folder 'Declare sub folder objects Set myToplvl = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders 'Set top level folder as Outlooks Inbox subfolders
For Each myFldr In myToplvl 'Sweep through each folder under the inbox
If myFldr.Items.Count < 1 Then 'If the folder is empty check for subfolders
If myFldr.Folders.Count < 1 Then 'If the folder contains not sub folders confirm deletion
response = MsgBox(myFldr.Name & " contains no items, would you like to delete it?", vbYesNo)
If response = vbYes Then 'If response is yes
myFldr.Delete 'Delete the folder
End If
Else 'Folder contains sub folders so confirm deletion
response = MsgBox(myFldr.Name & " contains no items but does contain subfolders, would you like to delete it?", vbYesNo)
If response = vbYes Then 'If response is yes
myFldr.Delete 'Delete folder and it's sub folders
End If
End If
Else 'Folder contains items so leave alone.
Debug.Print myFldr.Name & " contains items so would be left alone"
End If
Next
End Sub

As you can see from the code, this sub does exactly what is required. However, Richard threw me a bit of a curve ball and asked for it to be modified to allow the end user to choose there own folder to scan. Which is when I went back to the drawing board and came up with his little number:

'****************************************************************************************
'****************************************************************************************
'******
'****** Name: Purge empty outlook mail folders
'****** Description: Search Outlook Inbox subfolders and remove any unused
'****** Date: 30/12/2010
'****** Author: Mike Hudson - http://www.mikesel.info
'******
'****************************************************************************************
'****************************************************************************************
Public Sub FolderPurge()
Dim myToplvl As Folders 'Declare top level folder object
Dim myFldr As Folder 'Declare sub folder objects Set myToplvl = Outlook.GetNamespace("MAPI").PickFolder.Folders
For Each myFldr In myToplvl 'Sweep through each folder under the inbox
If myFldr.Items.Count < 1 Then 'If the folder is empty check for subfolders
If myFldr.Folders.Count < 1 Then 'If the folder contains not sub folders confirm deletion
response = MsgBox(myFldr.Name & " contains no items, would you like to delete it?", vbYesNo)
If response = vbYes Then 'If response is yes
myFldr.Delete 'Delete the folder
End If
Else 'Folder contains sub folders so confirm deletion
response = MsgBox(myFldr.Name & " contains no items but does contain subfolders, would you like to delete it?", vbYesNo)
If response = vbYes Then 'If response is yes
myFldr.Delete 'Delete folder and it's sub folders
End If
End If
Else 'Folder contains items so leave alone.
Debug.Print myFldr.Name & " contains items so would be left alone"
End If
Next
End Sub

This variation pops up Microsoft’s own ‘Folder Chooser’ allowing the user to choose their own starting point.

Hopefully someone will find this snippet useful.

Should you require assistance implementing this script, or modifying it please feel free to get in touch.