Code to move to a new folder emails sent or received on a specified day

This was posted to MrExcel in Aug 2014 but received no responses. So I am reposting here.

In order to compare emails relating to an annual reporting task, I would like to be able to move to a new Outlook folder emails sent or received on a particular day (regardless of year - that is, it would move all emails dated 1 Dec 2000, 1 Dec 2001, 1 Dec 2002, and so on). Ideally I'd like the user to be able to enter their chosen date in a dialog box. I've adapted the following code but it only deals with sent items, not received, and there's no dialog box. It's not quite right. Many thanks for your input.

Code:

---

Sub MoveEmail()
Dim olMAPI As Object    'Outlook.Application
Dim moveFolder As Object    'Outlook.MAPIFolder
Dim InItem As Object    'Outlook.MAPIFolder
Dim MItem As Object    'Outlook.MailItem
Dim sentDate As Date
Dim sentDate2 As Date
Dim myDay As Integer
Dim i As Integer
 
Set olMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set InItem = olMAPI.Folders("xtendlink (test)").Folders("Inbox")
Set moveFolder = olMAPI.Folders("xtendlink (test)").Folders("Inbox").Folders("old")
Set dltFolder = olMAPI.Folders("xtendlink (test)").Folders("Deleted Items")

i = 0

If InItem.Items.Count = 0 Then

MsgBox InItem.Items.Count

    MsgBox "There are no messages in the Referral Folder.", vbInformation, _
          "Nothing Found"
    Exit Sub
   
End If

Count = InItem.Items.Count
For i = Count To 1 Step -1
    Set MItem = InItem.Items.Item(i)
        mySub = MItem.Subject
    sentDate = Format(MItem.SentOn, "mm/dd")
        If sentDate = "12/01" Then
        MItem.Move moveFolder
    End If
   
Next
Set moveFolder = Nothing
Set dltFolder = Nothing
Set InItem = Nothing
Set MItem = Nothing
End Sub

---

Can we assume that the folder 'Old' already exists as a sub folder of Inbox; that you are running the macro from Excel and not Outlook; and the folder structure is otherwise standard? Then you need something like the following:

Note that if you are running from Excel, if Outlook is already running it is quicker to use the existing Outlook process rather than create another. If running from Outlook the code can be simplified.

As you want to process both the inbox and the sent items folders, you will have to process them separately.

Code:

---

Option Explicit
Sub MoveEmail()
Dim oOutlookApp As Object        'Outlook.Object
Dim olNS As Object        'Outlook.NameSpace
Dim moveFolder As Object        'Outlook.MAPIFolder
Dim inFolder As Object        'Outlook.MAPIFolder
Dim outFolder As Object
Dim MyReceivedItem As Object        'Outlook.MailItem
Dim MySentItem As Object
Dim sentDate As String
Dim askDate As String
Dim i As Long, j As Long
Dim inCount As Long, outCount As Long
Dim mySub As String

    On Error Resume Next
    'Get Outlook if it's running
    Set oOutlookApp = GetObject(, "Outlook.Application")

    'Outlook wasn't running, start it from code
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    askDate = InputBox("Enter the date in the format 'mm/dd'", "Process Date", "12/01")

    Set olNS = oOutlookApp.GetNamespace("MAPI")
    Set inFolder = olNS.GetDefaultFolder(6)
    Set outFolder = olNS.GetDefaultFolder(5) 'Note the deleted items folder would be (3)
    Set moveFolder = inFolder.Folders("Old")

    'Inbox
    inCount = inFolder.Items.Count
        If inCount = 0 Then
        MsgBox "There are no messages in the Inbox Folder.", vbInformation, _
              "InBox Folder"
        Exit Sub
    End If

    For i = inCount To 1 Step -1
        Set MyReceivedItem = inFolder.Items.Item(i)
        sentDate = Format(MyReceivedItem.SentOn, "mm/dd")
        If sentDate = askDate Then
            mySub = MyReceivedItem.Subject
            MyReceivedItem.Move moveFolder
        End If
    Next i

    'Sent Folder
    outCount = outFolder.Items.Count
    If outCount = 0 Then
        MsgBox "There are no messages in the Sent Items folder.", vbInformation, _
              "Sent Folder"
        Exit Sub
    End If

    For j = outCount To 1 Step -1
        Set MySentItem = outFolder.Items.Item(j)
        sentDate = Format(MySentItem.SentOn, "mm/dd")
        If sentDate = askDate Then
            mySub = MySentItem.Subject
            MySentItem.Move moveFolder
        End If
    Next j

    Set oOutlookApp = Nothing
    Set olNS = Nothing
    Set moveFolder = Nothing
    Set inFolder = Nothing
    Set outFolder = Nothing
    Set MyReceivedItem = Nothing
    Set MySentItem = Nothing
End Sub

---

Quote:

---

I'd like the user to be able to enter their chosen date in a dialog box.

---

you could use an inputbox, but better to put a monthview or other date control on a userform

you can test to see if this works for you, untested, so may contains some code errors or typos

Code:

---

inputdate = InputBox("enter date to move")
Set inb = GetNamespace("mapi").GetDefaultFolder(olFolderInbox)
Set dest = inb.Folders("test")
For y = 0 To -10 Step -1
    mydate = CDate(inputdate) + DateSerial(y, 0, 0)
    nxtday = CDate(mydate) + 1
    Set itms = inb.Items
    Set itms = itms.Restrict("[receivedtime] > '" & mydate & "' and [receivedtime] < '" & nxtday & "'")
    If itms.Count > 0 Then
        For i = itms.Count To 1 Step -1
            Set itm = itms(i)
            itm.Move dest
        Next
    End If
Next

---

change folders to suit, change max value for y to the number of years you want to move emails, for a specific day, starting from the year entered by the user and working back (10 years specified above, but can be any value)

Many thanks for your replies. Sorry for the delay in acknowledging - I've been sidetracked unavoidably but I will certainly use these.

Thanks again.