Copy emails in monthly archive

Question

I must copy emails that are older than 2 days in the monthly archive every day. My problem is if today is 01 or 02 .12.2016 then i must move the emails in the month before the current - 11.2016 . I cant get the code right - if email date is T-2 and email month is not the current then move the emails in the month before current month else move in the current month archive. Any help is welcomed, thank you.

Sub Archive_Outlook_eMails_To_Backup_PST_Folder()
    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder
    Dim MailItem As Outlook.MailItem
    Dim SourceMailBoxName As String, DestMailBoxName As String
    Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name  As String
    Dim MailsCount As Double, NumberOfDays As Double


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 " & b & " " & c


    NumberOfDays = 2

    Source_Pst_Folder_Name = "Inbox"
    Set SourceFolder = Session.Folders("Mailbox - Share ALL").Folders("Inbox").Folders("0.Archive")

    DestMailBoxName = nam
    Dest_Pst_Folder_Name = "0.Archive"
    Set DestFolder = Outlook.Session.Folders(DestMailBoxName).Folders(Dest_Pst_Folder_Name)

    MailsCount = SourceFolder.Items.Count
    While MailsCount > 0


        Set MailItem = SourceFolder.Items.Item(MailsCount)
        If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) >= NumberOfDays Then
            Dim myCopiedItem As Outlook.MailItem
            Set myCopiedItem = MailItem.Copy
            myCopiedItem.Move DestFolder

        End If

        MailsCount = MailsCount - 1

    Wend

    MsgBox "Mailes in " & Source_Pst_Folder_Name & " are Processed"
End Sub

Answer 1

Here is one possibility, to check the current date. If it is less than 3, then you go to the specific case:

Sub Archive_Outlook_eMails_To_Backup_PST_Folder()
    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder
    Dim MailItem As Outlook.MailItem
    Dim SourceMailBoxName As String, DestMailBoxName As String
    Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name  As String
    Dim MailsCount As Double, NumberOfDays As Double


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 " & b & " " & c


    NumberOfDays = 2

    Source_Pst_Folder_Name = "Inbox"
    Set SourceFolder = Session.Folders("Mailbox - Share ALL").Folders("Inbox").Folders("0.Archive")

    DestMailBoxName = nam
    Dest_Pst_Folder_Name = "0.Archive"
    Set DestFolder = Outlook.Session.Folders(DestMailBoxName).Folders(Dest_Pst_Folder_Name)

    MailsCount = SourceFolder.Items.Count
    While MailsCount > 0


        Set MailItem = SourceFolder.Items.Item(MailsCount)
        If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) >= NumberOfDays Then
        Select Case VBA.Now

        Case Is < 3:
            Dim myCopiedItem As Outlook.MailItem
            Set myCopiedItem = MailItem.Copy
            myCopiedItem.Move DestFolder 'The folder should be changed

        Case Else:
            Dim myCopiedItem As Outlook.MailItem
            Set myCopiedItem = MailItem.Copy
            myCopiedItem.Move DestFolder

        End If

        MailsCount = MailsCount - 1

    Wend

    MsgBox "Mailes in " & Source_Pst_Folder_Name & " are Processed"
End Sub

Just one small idea for improvement - put all your dim on top and not around the code like Dim myCopiedItem As Outlook.MailItem. They are initialized anyhow at the very beginning.