djheny1981
10-17-2016, 08:22 PM
Hi,
Please forgive my noobness.
My work has an email system that's particularly inefficient. In our active files, we have some 2883 active folders, many of these are empty after I run an auto-archive on them to remove items older than 12 months.
I suspect 3/4 of these folders are empty and it's a frustrating and tedious task to manually delete them. I'm looking for a script can can do this for me. I am using Office Profesisonal Plus 2010. I found this script but it seems to generate an error:
Public Sub DeletindEmtpyFolder()
Dim mytoplvl
Dim delFlag As Boolean
Set mytoplvl = Outlook.GetNamespace("MAPI").PickFolder.Folders
Do
FolderPurge mytoplvl, delFlag
Loop Until delFlag = False
Debug.Print " Done."
End Sub
Public Sub FolderPurge(mytoplvl, delFlag)
Dim myFldr As Folder 'Declare sub folder objects
delFlag = False
If mytoplvl.count <> 0 Then
Debug.Print "Analyzing: " & mytoplvl.GetFirst.Name & " delFlag:" & delFlag
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
Debug.Print myFldr.Name & " contains no items and no subfolders, and will be deleted."
myFldr.Delete 'Delete the folder
delFlag = True
Else 'Folder contains sub folders so confirm deletion
FolderPurge myFldr.Folders, delFlag
End If
Else 'Folder contains items or (subfolders that may be empty).
FolderPurge myFldr.Folders, delFlag
End If
Next myFldr
Else
Debug.Print "The folder does not contain any sub folders" & " delFlag:" & delFlag
End If
End Sub
The error occurs at line 27 - If myFldr.Items.count < 1 Then 'If the folder is empty check for subfolders
The error message is Run-Time Error '-313261817 (ed540107)':
The operation failed.
The intermediate window displays the following
Analyzing: ABBOTT, Luke delFlag:False
The folder does not contain any sub folders delFlag:False
The data folder it is looking at contains 3 emails, and thus it should skip it and not try to delete it, these item are archived in enterprise vault but visible.
If the first folder the script looks at is empty it deletes it, it just generates an error when there is something in the folder.
Any help would be greatly appreciated.
Please forgive my noobness.
My work has an email system that's particularly inefficient. In our active files, we have some 2883 active folders, many of these are empty after I run an auto-archive on them to remove items older than 12 months.
I suspect 3/4 of these folders are empty and it's a frustrating and tedious task to manually delete them. I'm looking for a script can can do this for me. I am using Office Profesisonal Plus 2010. I found this script but it seems to generate an error:
Public Sub DeletindEmtpyFolder()
Dim mytoplvl
Dim delFlag As Boolean
Set mytoplvl = Outlook.GetNamespace("MAPI").PickFolder.Folders
Do
FolderPurge mytoplvl, delFlag
Loop Until delFlag = False
Debug.Print " Done."
End Sub
Public Sub FolderPurge(mytoplvl, delFlag)
Dim myFldr As Folder 'Declare sub folder objects
delFlag = False
If mytoplvl.count <> 0 Then
Debug.Print "Analyzing: " & mytoplvl.GetFirst.Name & " delFlag:" & delFlag
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
Debug.Print myFldr.Name & " contains no items and no subfolders, and will be deleted."
myFldr.Delete 'Delete the folder
delFlag = True
Else 'Folder contains sub folders so confirm deletion
FolderPurge myFldr.Folders, delFlag
End If
Else 'Folder contains items or (subfolders that may be empty).
FolderPurge myFldr.Folders, delFlag
End If
Next myFldr
Else
Debug.Print "The folder does not contain any sub folders" & " delFlag:" & delFlag
End If
End Sub
The error occurs at line 27 - If myFldr.Items.count < 1 Then 'If the folder is empty check for subfolders
The error message is Run-Time Error '-313261817 (ed540107)':
The operation failed.
The intermediate window displays the following
Analyzing: ABBOTT, Luke delFlag:False
The folder does not contain any sub folders delFlag:False
The data folder it is looking at contains 3 emails, and thus it should skip it and not try to delete it, these item are archived in enterprise vault but visible.
If the first folder the script looks at is empty it deletes it, it just generates an error when there is something in the folder.
Any help would be greatly appreciated.