Move mail folders and subfolders on shared mail box to delete shared folder

Question

I have the following code in Outlook. On my first attempt the deleted mail was sent to my main account inbox and not the shared mailbox.

I would like to
1- pick the shared delete folder by default
2- avoid looping the delete folder
3- speed up the code if possible as size of mail box is > 1 Million mails. It is error free but I can track the progress.

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

Answer 1

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...

Answer 2

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:

• How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
• How To: Use Restrict method to retrieve Outlook mail items from a folder

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.