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

[1819]

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.



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

[gmayor]

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.


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

[westconn1]

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

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)

[1819]

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

Thanks again.