Copy old emails in archive subfolder - vba

Question

i have a code that copies the emails that are older than 2 days in an archive but if i want to copy the emails in an archive subfolder, it will not do the job. any help is welcomed.
Sub Copy_d_2()
Dim myOutlookFolders As Outlook.Folder
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Folder
Dim objSourceFolder As Outlook.Folder
Dim objSourceFolderMAIN As Outlook.Folder
Dim objDestFolder As Outlook.Folder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim a As Date
a = Now()
Dim b As String
b = Format(a, "mmmm")
Dim c As String
c = Format(a, "yyyy")
Dim nam As String
nam = "Archive me " & b & " " & c
Set objNamespace = Session.GetDefaultFolder(olFolderInbox)
Set objSourceFolder = Session.Folders("Mailbox - Share").Folders("Inbox").Folders("all emails")
Set objSourceFolderMAIN = Session.Folders("Archive Folders")
Set objDestFolder = Session.Folders("Archive Folders").Folders(nam).Folders("d2")
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
If intDateDiff > 2 Then
objVariant.Copy objDestFolder
lngMovedItems = lngMovedItems + 1
End If
End If
Next
Set objDestFolder = Nothing
End Sub

Answer 1

Here is something similar:
How to move each emails from inbox to a sub-folder
However, concerning your code, I have played a little and managed to do this:
Sub Copy_d_2()
Dim myOutlookFolders As Outlook.Folder
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Folder
Dim objSourceFolder As Outlook.Folder
Dim objSourceFolderMAIN As Outlook.Folder
Dim objDestFolder As Outlook.Folder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim a As Date
a = Now()
Dim b As String
b = Format(a, "mmmm")
Dim c As String
c = Format(a, "yyyy")
Dim nam As String
nam = "Archive me " & b & " " & c
Set objNamespace = Session.GetDefaultFolder(olFolderInbox)
Set objSourceFolder = Session.Folders("review#vitoshacademy.com").Folders("Posteingang").Folders("InboxX")
'Set objSourceFolderMAIN = Session.Folders("Archive")
Set objDestFolder = Session.Folders("Archive").Folders("test1").Folders("test2")
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
objVariant.Move objDestFolder
End If
Next
Set objDestFolder = Nothing
End Sub
It moves the mail to the subfolder without problems. And without checking whether it is at least 2 days old.