将指定日期范围内的 Outlook 电子邮件导入 Excel答案

【问题标题】：Import Outlook emails to Excel for specified Date Range将指定日期范围内的 Outlook 电子邮件导入 Excel
【发布时间】：2021-10-22 05:13:20
【问题描述】：

我正在尝试制作一个 excel 宏来将我的 Outlook 文件夹中的电子邮件导入到指定日期范围内的 excel 文件中（对于收到的电子邮件）。这个过程必须定期进行。因此，我需要继续在 Excel 工作表中的现有电子邮件下方添加电子邮件。

我得到了它的工作，但是，我的日期范围似乎不起作用。如果我只添加“发件人日期”，它会起作用并从指定的“发件人日期”导入所有电子邮件，直到最后收到的电子邮件。但是如果我指定一个日期范围，那么宏就根本不起作用，尽管它没有显示任何错误/调试。它只是告诉我导入已完成。在我的工作表中，单元格 L1 包含“起始日期”，单元格 L2 包含“截止日期”。

我该如何纠正这个问题？

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

根据建议，我使用以下代码进行了修改和测试。单元格 L1 的日期为 12/08/2021，单元格 L2 的日期为 16/08/2021。现在，代码会选择忽略晚于 2021 年 8 月 16 日的电子邮件的日期范围，但是，它不会获取 2021 年 8 月 16 日的电子邮件。它仅在 2021 年 8 月 15 日之前获取电子邮件。收件箱按“最新优先”排序，有日期为 12/08/2021 和 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

由于我发现从最旧到最新获取电子邮件最适合我，因此我尝试更改代码。但是，它退出循环而不做任何事情。我的邮箱从最旧到最新排序。我有 2019 年至今的电子邮件。我想获取以下给定范围内的电子邮件。单元格 L1 的起始日期为 (28/08/2020)。单元格 L2 有 To date (30/08/2020)。

这是我使用的代码。由于宏在第一个实例中退出循环，我认为我在逻辑中遗漏了一些东西。

另外，与其指示用户将他们的邮箱从最旧到最新排序，我们可以强制 VBA 这样做吗？ I tried OutlookItems.Sort [ReceivedTime], true 但收到错误“需要对象”。现在我在代码中做了注释。

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

【问题讨论】：

您的代码在发现一封不符合您的日期条件的邮件后立即退出循环...
@TimWilliams 非常感谢您的建议！我尝试删除该Else: GoTo 3，但随后宏将永远运行，因为我猜它会检查包含 8000 封电子邮件的整个邮箱。是否有机会在给定范围内获取宏接收电子邮件？
查找：行标签可以是任何以字母开头并以冒号 (:) 结尾的字符组合。行标签不区分大小写，必须从第一列开始。 注意以字母开头，以冒号结尾。此外，您应该将标签向上移动几行，紧跟在Next OutlookMail 之后，以关闭那些Folder ...
假设邮件按“最新优先”排序，L2 表示最后收到日期，L1 表示第一个收到日期，RD 表示收到日期，那么逻辑是：if RD > L2 then do_nothing else if RD >= L1 then get_mail_data else stop_looping .
您的第一个测试（如果接收时间 > L2 然后什么也不做）是正确的。下一个测试是错误的，你应该只测试`IF received time > L1 THEN copy the email ELSE exit the search。总共有 3 种情况：1) 电子邮件比 L2 新 - 不感兴趣。 2) 电子邮件比 L1 新 - 很有趣（您无需再次针对 L2 进行测试，您已经知道它比 L2 旧） 3) 电子邮件以及后续电子邮件较旧 - 不感兴趣，退出搜索。

标签： excel vba email outlook

【解决方案1】：

这里是选择代码逻辑

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

【讨论】：

非常感谢您帮助我！我试过了，但它仍然会获取单元格 L2 中提到的日期前 1 天的电子邮件。
问题可能是邮件接收时间中的时间部分。如果您的 L2 条目是例如16.08.2021 这意味着那天 00:00:00。因此，过滤掉了在 16.08.2021 12:00:00 收到的电子邮件。我建议您在公式中将 L2 值增加一天：（(Range("L2").Value) + 1)）。备选方案 1) 指示用户输入下一天的日期。备选方案 2) 从电子邮件日期时间中删除时间部分。
非常感谢您的建议！我改变了它，它工作正常。再次感谢您在这方面的帮助！

【解决方案2】：

如果您要根据日期退出处理循环，最好按照您期望的顺序对我们的项目进行排序。

改变

Dim OutlookMail As Variant

到

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

改变

For Each OutlookMail In Folder.Items

到

 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

一旦按照正确的顺序，您就可以使用接收时间过滤器记录电子邮件

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

【讨论】：

非常感谢您花时间为我修改代码！我根据您的建议更改了代码。不幸的是，宏不会获取任何电子邮件。我猜当第一封电子邮件不符合搜索条件时它会退出循环。

【解决方案3】：

在这个平台上的专家的帮助下，我修改了代码并得到了我想要的。发布它以防将来有人寻找类似的东西。

衷心感谢所有花时间帮助我的人。

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

【讨论】：

【解决方案4】：

另一种方法是将电子邮件项目（在此示例中）限制为某个日期。我最近才使用这种方法，效果很好。反转排序也很容易，虽然我也喜欢“OutlookItems.Sort [ReceivedTime], true ' 升序排序”方法。

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

到目前为止我错过的关于 Outlook 限制的另一个问题： Using Restrict method for emails within a specified date

【讨论】：

感谢分享！欣赏！