Outlook Clean up move mail folders and subfolders on shared mail box to delete SH folder-CodePudding

I get the follwoing code,a DYI from me :) I manage to get the delete pcik up but ideally I would like to 1- get the sh delete folder pick by default for deleting 2- Avoid the looping the delte folder 3- Speed up the code if possible as size of mail box is > 1 Million mails 4- I manage to get it erro free but can track the progress.....

Can anyone help? thanks in advance

Dim objNameSpace As Outlook.NameSpace
Dim objMainFolder As Outlook.Folder
Dim olNs As NameSpace
Dim lngItem As Long
Dim Mails_itm As MailItem
Dim myNameSpace As Outlook.NameSpace
Dim myInboxDest As Outlook.Folder
Dim myInboxSc As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object

Set objNameSpace = Application.GetNamespace("MAPI")
Set objMainFolder = objNameSpace.PickFolder

 Call ProcessCurrentFolder(objMainFolder)

End Sub

ProcessCurrentFolder(ByVal objParentFolder As Outlook.MAPIFolder)

    Dim objCurFolder As Outlook.MAPIFolder
    Dim objMail As Outlook.MailItem
    Dim DeletedFolder As Outlook.Folder
    Dim olNs As Outlook.NameSpace
    Dim lngItem As Long
    On Error Resume Next
  
    Set olNs = Application.GetNamespace("MAPI")
    Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
   For Each objMail In objParentFolder.Items
     i = 0
     For lngItem = objParentFolder.Items.Count To 1 Step -1
        Set objMail = objParentFolder.Items(lngItem)
        If TypeName(objMail) = "MailItem" Then
            If ((objMail.ReceivedTime) < DateAdd("yyyy", -7, Date)) Then         
                    objMail.Move DeletedFolder
               i = i   1
            End If
        End If
        DoEvents
        Next lngItem
    Next
    If (objParentFolder.Folders.Count > 0) Then
        For Each objCurFolder In objParentFolder.Folders
            Call ProcessCurrentFolder(objCurFolder)
        Next
    End If
End Sub

CodePudding user response：

Use the Find/FindNext or Restrict methods to get items that correspond to your conditions instead of iterating over all items in the folder. Read more about these methods in the following articles:

When you iterate over found items and move them to another folder you must use a reverse loop which allows prevent errors at runtime because decreasing the number of items by calling the Move method leads to decreasing the number of items.

Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
    Dim objCurFolder As outlook.MAPIFolder
    Dim objMail As outlook.MailItem
    Dim DeletedFolder As outlook.Folder
    Dim olNs As outlook.NameSpace
    Dim lngItem As Long, strFilter As String, oItems As items
  
    Set olNs = app.GetNamespace("MAPI")
    Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
    
    strFilter = "[ReceivedTime] < '" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
    Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
     Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
  For i = oItems.Count to 1 Step -1
        Set objMail = oItems(i)
        objMail.Move DeletedFolder
  Next
   
   ' it makes sense to move this part to the beginning of the method to process subfolders first  
   If (objParentFolder.Folders.count > 0) Then
        For Each objCurFolder In objParentFolder.Folders
            Call ProcessCurrentFolder(objCurFolder, app)
        Next
   End If
End Sub

See For Each loop: Some items get skipped when looping through Outlook mailbox to delete items for more information.

CodePudding user response：

When placing a question, it is good to check it from time to time and answer the clarification questions, if any...

Supposing that your first required issue means replacing the folder picker option and directly setting objMainFolder, your first code should be adapted as:

Sub ProcessOldMails()
 Dim objNameSpace As outlook.NameSpace
 Dim objMainFolder As outlook.Folder

 Set Out = GetObject(, "Outlook.Application")
 Set objNameSpace = Out.GetNamespace("MAPI")

 Set objNameSpace = Application.GetNamespace("MAPI")
 'Set objMainFolder = objNameSpace.PickFolder 'uncomment if my supposition is wrong
 'set the folder to be processed directly, if it is an InBox subfolder:
 'Please use its real name instead of "MyFolderToProcess":
 Set objMainFolder = objNameSpace.GetDefaultFolder(olFolderInbox).Folders("MyFolderToProcess")
    ProcessCurrentFolder objMainFolder, Application
End Sub

In order to make the process faster, you can filter the folder content and iterate only between the remained mails:

Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
    Dim objCurFolder As outlook.MAPIFolder
    Dim objMail As outlook.MailItem
    Dim DeletedFolder As outlook.Folder
    Dim olNs As outlook.NameSpace
    Dim lngItem As Long, strFilter As String, oItems As items
  
    Set olNs = app.GetNamespace("MAPI")
    Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
    
    strFilter = "[ReceivedTime]<'" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
    Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
     Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
   For lngItem = oItems.count To 1 Step -1
       oItems(lngItem).Move DeletedFolder
   Next lngItem
   If (objParentFolder.Folders.count > 0) Then
        For Each objCurFolder In objParentFolder.Folders
            Call ProcessCurrentFolder(objCurFolder, app)
        Next
   End If
End Sub

I used app second parameter only because I tried it as an Outlook automation from Excel, and it was easier to insert only two lines...

Please, test the suggested solution and send some feedback. If my understanding was not a correct one, do not hesitate to ask for clarifications, firstly answering my questions from the comment.

Now, I need to go out...