1

I am trying to make an excel macro to import emails from my outlook folder into an excel file for a specified date range (for received emails). This process has to be done on a regular basis. Hence, I need to go on adding the emails below the existing emails in the excel sheet.

I got that to work, however, my date range does not seem to work. If I add only 'From date', it works and imports all the emails from the specified 'From date' until the last received email. But if I specify a range of dates, then the macro doesn't work at all, although it does not show any error/ debug. It just gives me the message that the import is done. In my sheet cell L1 contains 'From date' and cell L2 contains 'To date'.

How can I correct this?

Sub Download_Emails()

Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxx.com")   
objOwner.Resolve

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1

For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) >= Range("L1").Value And CDate(OutlookMail.ReceivedTime) <= Range("L2").Value Then

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date set is crossed, then to to line number 3
Else: GoTo 3

End If
End If

Next OutlookMail
 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
3 Sheet1.Cells.WrapText = False
 

Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub

After suggestions, I modified and tested with the below code. Cell L1 has date 12/08/2021 and cell L2 has date 16/08/2021. Now the code picks up the date range ignoring the emails that are later than 16/08/2021, however, it does not fetch the emails for the date 16/08/2021. It fetches the emails only until 15/08/2021. Inbox is sorted according to "Latest first" and there are emails for date 12/08/2021 and for 16/08/2021.

Sub Download_Emails()

Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxxx.com")   'Set the Outlook mailbox name
objOwner.Resolve

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1


For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) > Range("L2").Value Then
    'Do nothing

ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then ‘L1 has date 12/08/2021 and L2 has date 16/08/2021

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date range is crossed, then exit For loop
Else: Exit For

End If
End If


Next OutlookMail
 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
Sheet1.Cells.WrapText = False
 
Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub

Since I find fetching emails from Oldest to Newest suits me best, I tried to alter the codes. However, it exits the loop without doing anything. My mailbox is sorted from Oldest to Newest. I have emails from 2019 till date. I want to fetch emails that I have for the below given range. Cell L1 has the From date (28/08/2020). Cell L2 has the To date (30/08/2020).

Here is the code that I used. Since the macro exits the loop at the first instance, I think I am missing something in the logic.

Also, rather than instructing the user to have their mailbox sorted from oldest to newest, can we force the VBA to do that? I tried OutlookItems.Sort [ReceivedTime], true but got the error "Object Required". Now I have made it a comment in the code.

Sub Download_Emails()


Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long
Dim ToDt As Date

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

ToDt = Range("L2").Value + 1

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxxxxxxx.com")   'Set the Outlook mailbox name
objOwner.Resolve

'OutlookItems.Sort [ReceivedTime], true (results in error Object required)

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1


For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) < Range("L1").Value Then   'From Date
    'Do nothing
    
ElseIf CDate(OutlookMail.ReceivedTime) < ToDt Then   'To Date

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date range is crossed, then exit For loop
Else: Exit For
End If
End If

Next OutlookMail
 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
Sheet1.Cells.WrapText = False
 
Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub
Seema
  • 33
  • 9
  • 1
    Your code exits the loop as soon as it finds one mail which doesn't meet your date criteria... – Tim Williams Aug 20 '21 at 17:17
  • @TimWilliams Thank you very much for the suggestion!! I tried removing that ```Else: GoTo 3```, but then the macro runs forever because I guess it checks the entire mailbox that has 8000 emails. Is there chance to get the macro pick up emails for a given range? – Seema Aug 20 '21 at 17:51
  • Maybe look here for how to query specific mails - https://stackoverflow.com/questions/59106171/select-new-email-by-subject-and-date-range – Tim Williams Aug 20 '21 at 17:55
  • 2
    Looking it up: *A line label can be any combination of characters that starts with a letter and ends with a colon (:). Line labels are not case sensitive and must begin in the first column.* Note ***starts with a letter and ends with a colon***. Also, you should move the label up a few lines, to right after `Next OutlookMail` in order to close those `Folder` ... – Tom Brunberg Aug 20 '21 at 18:20
  • What are values showing up if you DEBUG.PRINT Range("L1").Value and Range("L2").Value – dbmitch Aug 20 '21 at 18:37
  • You should also delete that "3" in the RwapText line, and just replace your Else: GoTo line with Else: Exit For – dbmitch Aug 20 '21 at 19:00
  • @TimWilliams, Thanks a lot! I will go through that. – Seema Aug 20 '21 at 19:13
  • @TomBrunberg, Thanks! I will keep that in mind. – Seema Aug 20 '21 at 19:14
  • @dbmitch, `Else: Exit For` worked like a magic!! Thank you so very much!! About DEBUG.PRINT Range("L1").Value and Range("L2").Value - It was showing 44424 DEBUG.PRINT Range("L1").Value was showing 17/08/2021 (which is a value in cell L1) DEBUG.PRINT Range("L2").Value was showing 20/08/2021 (which is a value in cell L2) – Seema Aug 20 '21 at 19:22
  • @dbmitch A small correction, `Else: Exit For ` works, emails within the specified range are picked up, but the 'To Date' has to be current date. For instance, if I specify the range as from 10-Jul-2021 to 20-Jul-2021, the macro doesn't work. It exits the loop. If I specify the date as from 10-Jul-2021 to 20-Aug-2021, then it works fine. I was looking for a desired date range, not only until today. Do you still have a suggestion for me? – Seema Aug 20 '21 at 20:30
  • 1
    Assuming the mails are ordered "latest first", `L2` means last date to get, `L1` means first date to get and RD means received date, then the logic would be: `if RD > L2 then do_nothing else if RD >= L1 then get_mail_data else stop_looping`. – Tom Brunberg Aug 20 '21 at 21:18
  • Am I missing something? Just change the date in Cell L2 to be what you want - 20/07/2021 – dbmitch Aug 20 '21 at 21:19
  • @TomBrunberg, doesn't work, unfortunately :( Gets out of the loop without doing anything. – Seema Aug 22 '21 at 12:08
  • @dbmitch, I did that. For example, my L1 has 16/08/2021 and L2 has 18/08/2021. The macro does not seem to pick up that range. But if L1 has 16/08/2021 and L2 has today's date, then works fine. Looks like once the macro comes across an email that doesn't meet the criteria (may be an email from 20/08/2021), the macro exits the loop. – Seema Aug 22 '21 at 12:18
  • What dates (L1 and L2) did you test with. Do you have emails dated later than L2, between L2 and L1 and earlier than L1? Please show your actual code you tested with (edit your question to add it), otherwise it is impossible to pinpoint your error. – Tom Brunberg Aug 22 '21 at 12:58
  • @TomBrunberg, In fact your suggestion helped to set the range, however, there is another small problem. I have posted the edited code and the issue related to that. Could you please take a look? Thank you very much for taking time to help me on this! – Seema Aug 22 '21 at 13:33
  • 1
    Your first test (IF received time > L2 then do nothing) is correct. The next test is wrong, you should only test `IF received time > L1 THEN copy the email ELSE exit the search. There are 3 cases in all: **1)** the email is newer than L2 - **not interesting**. **2)** the email is newer than L1 - **it is interesting** (you don't need to test against L2 again, you already know it is older than L2) **3)** the email, as well as subsequent ones, is older - not interesting, **exit the search**. – Tom Brunberg Aug 22 '21 at 13:57
  • @TomBrunberg, Your comment made so much more sense to me! I modified as you suggested `ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then` The only problem I have now is that it does not pick up the emails including the ones for the date in cell L2 even though the ReceivedTime is >=. For instance, If date in L2 is 16/08/2021, it fetches the emails only until 15/08/2021. I have emails for 16/08/2021 in the mailbox. I have edited the code in the post. Am I missing something trivial here? – Seema Aug 22 '21 at 15:18
  • You're not setting Folder anywhere. You haven't presorted your mail items. It could exit at any time based on item's received date – dbmitch Aug 22 '21 at 16:10
  • @dbmitch The code `Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder` lets me select folder each time, and I am trying by selecting the same folder every time. Sorry, by mistake I made that code as a comment in the post. Corrected now. – Seema Aug 22 '21 at 16:21
  • @TomBrunberg, Could you please help me with one more logic in here? I am thinking it is more practical to fetch the emails from "Oldest to Newest". My mailbox is sorted from "Oldest first". Then I tried to change the code like this ` If CDate(OutlookMail.ReceivedTime) < Range("L1").Value Then 'Do nothing ElseIf CDate(OutlookMail.ReceivedTime) <= Range("L2").Value Then 'Get emails ` I am missing something in the logic here. The macro exits the loop with the first instance. First email in the inbox is from 2019. L1 has 10/04/2020 and L2 has 14/04/2020. – Seema Aug 25 '21 at 18:37
  • Seems quite close, but you are missing the final `Else Exit For`. You need to add the +1 to L2 in this case too, if you want to get the mails for the whole day L2. So: `If CDate(OutlookMail.ReceivedTime) < Range("L1").Value Then 'Do nothing ElseIf CDate(OutlookMail.ReceivedTime) < Range("L2").Value Then 'Get email Else Exit For`. I removed the "=" from "<=" Range("L2")... because otherwise you would potentially get an email received next day. If you need further help, you need to post a new question with proper code and sample dates. Result of single stepping through the code is also advised. – Tom Brunberg Aug 25 '21 at 20:16
  • @TomBrunberg, I had tried what you have suggested, but the macro was exiting the loop without fetching any emails. I understand that it is difficult to analyse without the entire code. My sincere apologies. I have posted the code that I tried. Could you please take a look? – Seema Aug 26 '21 at 04:29
  • Seema, when I asked you to post a new question I meant literally a new Stack Overflow question post. It is against the policies to add followup questions, because those chains tend to grow endlessly. Also, I asked you to provide debugging results by **single stepping through code**. In this case the interesting details are **why the code thinks it should stop processing emails**. What `ReceivedTime` `L1` and `L2` values are involved for the first and following emails. This might already clarify the problem for you. – Tom Brunberg Aug 26 '21 at 06:42
  • @TomBrunberg, I am sorry, I did not know about this policy. I will adhere to it hereafter. Now I have created a new post. And, I had tried single stepping through and macro was exiting the loop after the first email. Thanks once again for all your help and suggestions! – Seema Aug 26 '21 at 13:03

4 Answers4

1

Here's the selection code logic

For Each OutlookMail In Folder.Items
    If TypeName(OutlookMail) = "MailItem" Then

        If CDate(OutlookMail.ReceivedTime) > Range("L2").Value Then
            'do nothing, newer than the selected range

        ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then
                'meaning that L2 => date >= L1
                'import email

            Else

                'date is < L1 not interested in these
                Exit For
            End If               
        End If
    End If
Next OutlookMail
Tom Brunberg
  • 20,312
  • 8
  • 37
  • 54
  • Thanks so much for trying to help me! I tried, but it still fetches emails that are 1 day prior to the date mentioned in Cell L2. – Seema Aug 22 '21 at 19:04
  • Probably the issue is the time component in the received time of a mail. If your L2 entry is e.g. 16.08.2021 it means that day at 00:00:00. An email received at 16.08.2021 12:00:00 is therefore filtered out. I suggest you increase the L2 value by one day in the formula: ( `(Range("L2").Value) + 1)` ). Alternative 1) direct the user to enter next days date. Alternative 2) remove the time component from the email datetime. – Tom Brunberg Aug 22 '21 at 19:55
  • Thanks so much for the suggestion! I changed that and, it works fine. Once again, thanks a lot for helping me out on this! – Seema Aug 22 '21 at 20:13
0

If you're going to exit your processing loop based on the date, you better sort our items in the same order you expect.

Change

Dim OutlookMail As Variant

To

Dim OutlookMail As Outlook.MailItem
Dim OutlookItems As Outlook.Items

Change

For Each OutlookMail In Folder.Items

To

 Set OutlookItems = Folder.Items
 NumItems = OutlookItems.Count
 If NumItems = 0 Then Exit Sub

 OutlookItems.Sort [ReceivedTime], true ' sort in ascending order

 For Each OutlookMail In OutlookItems

Once in correct order you can record emails using Received Time filter

If CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then 'low filter

   IF CDate(OutlookMail.ReceivedTime) <= Range("L2").Value Then ' high filter
      ' Record your email data here
      '  ...
   Else ' All done - outside our processing range
      Exit For

   End If
End IF
dbmitch
  • 5,361
  • 4
  • 24
  • 38
  • Thanks so much for taking time to modify the codes for me! I changed the codes as per your suggestion. Unfortunately, the macro doesn't fetch any emails. I guess it exits the loop when the very first email doesn't meet the search criteria. – Seema Aug 22 '21 at 19:01
0

With all the help that I got from experts on this platform, I modified the codes and got what I wanted. Posting it in case it helps someone looking for something like this in the future.

Sincere thanks to everyone who took time to help me.

Sub Download_Emails()


Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long
Dim ToDt As Date

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

ToDt = Range("L2").Value + 1

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxxxxxxx.com")   'Set the Outlook mailbox name
objOwner.Resolve

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1


For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) > ToDt Then
    'Do nothing
    
ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date range is crossed, then exit For loop
Else: Exit For
End If
End If

Next OutlookMail


 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
Sheet1.Cells.WrapText = False

 
Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub
Seema
  • 33
  • 9
0

Another method is to Restrict the email items, in this example, to a certain date. I just used this method recently and it works great. It is also easy to reverse the sort, although I liked the "OutlookItems.Sort [ReceivedTime], true ' sort in ascending order" method too.

Items.Restrict method (Outlook)

Sub GetFromOutlook()
    Dim i As Integer
    Dim EmailSender As String

Dim myOlApp As Outlook.Application
Dim myNamespace As Namespace
Dim myFolder As MAPIFolder
Dim OutlookMail As Variant

Set myOlApp = New Outlook.Application
Set myNamespace = myOlApp.GetNamespace("MAPI")

Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox) '.Folders("Inbox") '.Folders("Subfolder")
    Set myItems = myFolder.Items

i = 1

     
Dim DateStart As Date
DateStart = #1/1/2021#
DateStart = Replace(DateStart, "1/1/2021", LastNewEmailDate)
Dim DateToCheck As String
    DateToCheck = "[LastModificationTime] >= """ & DateStart & """"
    
    Set myRestrictItems = myItems.Restrict(DateToCheck)      'Restrict("[Categories] = 'Business'")

Debug.Print "restrict count: " & myRestrictItems.Count

'Oldest first:
    For i = 1 To myRestrictItems.Count Step +1
'Newest first
   ' For i = myRestrictItems.Count To 1 Step -1

        If myRestrictItems(i).SenderEmailType = "SMTP" Then
            EmailSender = myRestrictItems(i).SenderEmailAddress
        End If

Debug.Print myRestrictItems(i).ReceivedTime

Next i

End Sub

Another Question on Outlook Restrictions that I had missed until now: Using Restrict method for emails within a specified date

Keith Swerling
  • 136
  • 1
  • 6