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
|
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 |
'**************************************************************************************** '**************************************************************************************** '****** '****** Name: Purge empty outlook mail folders '****** Description: Search Outlook Inbox subfolders and remove any unused '****** Date: 30/12/2010 '****** Author: Mike Hudson - https://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:
|
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 |
'**************************************************************************************** '**************************************************************************************** '****** '****** Name: Purge empty outlook mail folders '****** Description: Search Outlook Inbox subfolders and remove any unused '****** Date: 30/12/2010 '****** Author: Mike Hudson - https://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.