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

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.