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