UncleBill
Member
- Outlook version
- Outlook 2010 64 bit
- Email Account
- POP3
Sincerest apologies if I'm re-treading old ground.....I've really, really made an effort to review existing posts.
I'm using Outlook 2010. I have multiple POP3 yahoo accounts and multiple IMAP gmail accounts.
I've written (portions blatantly plagiarized) a VBA macro that I intend to manually invoke. It scans all accounts looking for 'Sent Items', 'Sent Mail', and 'Junk E-mail' folders, deleting items 7 days or older.
My Outlook accounts are configured to move items to the 'Deleted Items" or 'Trash' folders when an item is deleted.
This macro functionality works as expected.
The macro then scans the items in the 'Deleted Items' and 'Trash' folders, deleting items 14 days or older. Although this produces no error, the items selected in the IMAP 'Trash' folders are not deleted. At macro end, they still reside in the 'Trash' folder.
What additional must I do to force the delete?
My admittedly rookie code follows: (helpful critiquing welcome)
'**************************************************************************************************
'Description:
' This VBA Script iterates thru all accounts, all folders.
' If the folder meets the selection criteria, then its items => 7 days old are deleted.
' The Trash (IMAP) and Deleted Items (POP3) folders are then processed, deleting items => 14 days old.
'**************************************************************************************************
Const DAYS_OLD = 7
Sub Iterate_Accounts_Delete_Folder_Contents()
IterateAccountsDeleteFolderContents
End Sub
Private Sub IterateAccountsDeleteFolderContents()
On Error GoTo On_Error
Dim objNS As NameSpace
Dim objAccount As Outlook.account
Dim objFolders As Outlook.Folders
Dim objFolder As Outlook.folder
Dim subFolder As Outlook.folder
Dim objFoldersToProcess As Outlook.Folders
Dim objItemsToProcess As Outlook.Items
Dim i As Long
Set objNS = Application.GetNamespace("MAPI")
Set objFolders = objNS.Folders
For Each objFolder In objFolders
Set objAccount = GetAccountForFolder(objFolder)
DisplayAccountNameAndType objAccount
For Each subFolder In objFolder.Folders
If (subFolder.Name = "Sent Items") Or (subFolder.Name = "Sent Mail") Or (subFolder.Name = "Junk E-mail") Then
Debug.Print " Folder selected for processing = " + subFolder.Name
Set objItemsToProcess = subFolder.Items
For i = objItemsToProcess.Count To 1 Step -1
If Date - objItemsToProcess.Item(i).ReceivedTime >= DAYS_OLD Then
Debug.Print " Item being deleted = " + objItemsToProcess.Item(i) + " : " + Str(objItemsToProcess.Item(i).ReceivedTime)
objItemsToProcess.Item(i).Delete
End If
Next
Set objFoldersToProcess = subFolder.Folders
For i = objFoldersToProcess.Count To 1 Step -1
If Date - objFoldersToProcess.Item(i).ReceivedTime >= DAYS_OLD Then
Debug.Print " Folder being deleted = " + objFoldersToProcess.Item(i).Name + " : " + Str(objFoldersToProcess.Item(i).ReceivedTime)
objFoldersToProcess.Item(i).Delete
End If
Next
End If
Next
For Each subFolder In objFolder.Folders
If (subFolder.Name = "Trash") Or (subFolder.Name = "Deleted Items") Then
Debug.Print " Folder selected for processing = " + subFolder.Name
Set objItemsToProcess = subFolder.Items
For i = objItemsToProcess.Count To 1 Step -1
If Date - objItemsToProcess.Item(i).ReceivedTime >= (2 * DAYS_OLD) Then
Debug.Print " Item being deleted = " + objItemsToProcess.Item(i) + " : " + Str(objItemsToProcess.Item(i).ReceivedTime)
objItemsToProcess.Item(i).Delete
End If
Next
Set objFoldersToProcess = subFolder.Folders
For i = objFoldersToProcess.Count To 1 Step -1
If Date - objFoldersToProcess.Item(i).ReceivedTime >= (2 * DAYS_OLD) Then
Debug.Print " Folder being deleted = " + objFoldersToProcess.Item(i).Name + " : " + Str(objFoldersToProcess.Item(i).ReceivedTime)
objFoldersToProcess.Item(i).Delete
End If
Next
End If
Next
Next
Set objNS = Nothing
Set objAccount = Nothing
Exiting:
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Private Function GetAccountForFolder(objFolder As Outlook.folder) As Outlook.account
Dim objStoreID As String
objStoreID = objFolder.StoreID
'Enumerate the accounts defined for the session.
For Each account In Application.session.accounts
If account.DeliveryStore.StoreID = objStoreID Then
'Return the account whose default delivery StoreID matches the folder StoreID
Set GetAccountForFolder = account
Exit Function
End If
Next
'No account matches, so return Nothing.
Set GetAccountForFolder = Nothing
End Function
Private Sub DisplayAccountNameAndType(ByVal objAccount As Outlook.account)
Debug.Print ("")
Debug.Print objAccount.DisplayName
If (objAccount.AccountType = Outlook.OlAccountType.olImap) Then
Debug.Print "Account Type = IMAP"
ElseIf (objAccount.AccountType = Outlook.OlAccountType.olPop3) Then
Debug.Print "Account Type = POP3"
Else
Debug.Print "Account Type = UNKNOWN"
End If
End Sub
I'm using Outlook 2010. I have multiple POP3 yahoo accounts and multiple IMAP gmail accounts.
I've written (portions blatantly plagiarized) a VBA macro that I intend to manually invoke. It scans all accounts looking for 'Sent Items', 'Sent Mail', and 'Junk E-mail' folders, deleting items 7 days or older.
My Outlook accounts are configured to move items to the 'Deleted Items" or 'Trash' folders when an item is deleted.
This macro functionality works as expected.
The macro then scans the items in the 'Deleted Items' and 'Trash' folders, deleting items 14 days or older. Although this produces no error, the items selected in the IMAP 'Trash' folders are not deleted. At macro end, they still reside in the 'Trash' folder.
What additional must I do to force the delete?
My admittedly rookie code follows: (helpful critiquing welcome)
'**************************************************************************************************
'Description:
' This VBA Script iterates thru all accounts, all folders.
' If the folder meets the selection criteria, then its items => 7 days old are deleted.
' The Trash (IMAP) and Deleted Items (POP3) folders are then processed, deleting items => 14 days old.
'**************************************************************************************************
Const DAYS_OLD = 7
Sub Iterate_Accounts_Delete_Folder_Contents()
IterateAccountsDeleteFolderContents
End Sub
Private Sub IterateAccountsDeleteFolderContents()
On Error GoTo On_Error
Dim objNS As NameSpace
Dim objAccount As Outlook.account
Dim objFolders As Outlook.Folders
Dim objFolder As Outlook.folder
Dim subFolder As Outlook.folder
Dim objFoldersToProcess As Outlook.Folders
Dim objItemsToProcess As Outlook.Items
Dim i As Long
Set objNS = Application.GetNamespace("MAPI")
Set objFolders = objNS.Folders
For Each objFolder In objFolders
Set objAccount = GetAccountForFolder(objFolder)
DisplayAccountNameAndType objAccount
For Each subFolder In objFolder.Folders
If (subFolder.Name = "Sent Items") Or (subFolder.Name = "Sent Mail") Or (subFolder.Name = "Junk E-mail") Then
Debug.Print " Folder selected for processing = " + subFolder.Name
Set objItemsToProcess = subFolder.Items
For i = objItemsToProcess.Count To 1 Step -1
If Date - objItemsToProcess.Item(i).ReceivedTime >= DAYS_OLD Then
Debug.Print " Item being deleted = " + objItemsToProcess.Item(i) + " : " + Str(objItemsToProcess.Item(i).ReceivedTime)
objItemsToProcess.Item(i).Delete
End If
Next
Set objFoldersToProcess = subFolder.Folders
For i = objFoldersToProcess.Count To 1 Step -1
If Date - objFoldersToProcess.Item(i).ReceivedTime >= DAYS_OLD Then
Debug.Print " Folder being deleted = " + objFoldersToProcess.Item(i).Name + " : " + Str(objFoldersToProcess.Item(i).ReceivedTime)
objFoldersToProcess.Item(i).Delete
End If
Next
End If
Next
For Each subFolder In objFolder.Folders
If (subFolder.Name = "Trash") Or (subFolder.Name = "Deleted Items") Then
Debug.Print " Folder selected for processing = " + subFolder.Name
Set objItemsToProcess = subFolder.Items
For i = objItemsToProcess.Count To 1 Step -1
If Date - objItemsToProcess.Item(i).ReceivedTime >= (2 * DAYS_OLD) Then
Debug.Print " Item being deleted = " + objItemsToProcess.Item(i) + " : " + Str(objItemsToProcess.Item(i).ReceivedTime)
objItemsToProcess.Item(i).Delete
End If
Next
Set objFoldersToProcess = subFolder.Folders
For i = objFoldersToProcess.Count To 1 Step -1
If Date - objFoldersToProcess.Item(i).ReceivedTime >= (2 * DAYS_OLD) Then
Debug.Print " Folder being deleted = " + objFoldersToProcess.Item(i).Name + " : " + Str(objFoldersToProcess.Item(i).ReceivedTime)
objFoldersToProcess.Item(i).Delete
End If
Next
End If
Next
Next
Set objNS = Nothing
Set objAccount = Nothing
Exiting:
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Private Function GetAccountForFolder(objFolder As Outlook.folder) As Outlook.account
Dim objStoreID As String
objStoreID = objFolder.StoreID
'Enumerate the accounts defined for the session.
For Each account In Application.session.accounts
If account.DeliveryStore.StoreID = objStoreID Then
'Return the account whose default delivery StoreID matches the folder StoreID
Set GetAccountForFolder = account
Exit Function
End If
Next
'No account matches, so return Nothing.
Set GetAccountForFolder = Nothing
End Function
Private Sub DisplayAccountNameAndType(ByVal objAccount As Outlook.account)
Debug.Print ("")
Debug.Print objAccount.DisplayName
If (objAccount.AccountType = Outlook.OlAccountType.olImap) Then
Debug.Print "Account Type = IMAP"
ElseIf (objAccount.AccountType = Outlook.OlAccountType.olPop3) Then
Debug.Print "Account Type = POP3"
Else
Debug.Print "Account Type = UNKNOWN"
End If
End Sub