Скопируйте старые письма в подпапку архива

Question

У меня есть код, который копирует электронные письма, которые старше 2 дней в архиве, но если я хочу скопировать электронные письма в подпапку архива, он не выполнит эту работу. любая помощь приветствуется.

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

Вот что-то подобное: How to move each emails from inbox to a sub-folder

Однако, что касается кода, я играл мало, и это удалось сделать:

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 

Он перемещает почту в подпапку без проблемы. И не проверяя, как минимум 2 дня.