将指定日期范围内的 Outlook 电子邮件导入 Excel
Import Outlook emails to Excel for specified Date Range
我正在尝试制作一个 excel 宏，以便将电子邮件从我的 outlook 文件夹导入到指定日期范围内的 excel 文件（对于收到的电子邮件）。这个过程必须定期进行。因此，我需要继续在 excel sheet.
中的现有电子邮件下方添加电子邮件
我成功了，但是，我的日期范围似乎不起作用。如果我只添加 'From date'，它会工作并导入从指定的 'From date' 到最后收到的电子邮件的所有电子邮件。但是如果我指定了一个日期范围，那么宏就根本不起作用，尽管它没有显示任何错误/调试。它只是告诉我导入已完成。在我的 sheet 单元格 L1 中包含 'From date' 并且单元格 L2 包含 'To date'.
我该如何纠正？
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。现在代码选择日期范围，忽略晚于 16/08/2021 的电子邮件，但是，它不会获取日期为 16/08/2021 的电子邮件。它仅在 15/08/2021 之前提取电子邮件。收件箱按照“最新优先”排序，有日期为 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 的截止日期为 (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
这里是选择代码逻辑
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
如果您要退出基于日期的处理循环，您最好按照您期望的相同顺序对我们的项目进行排序。
改变
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
在这个平台专家的帮助下，我修改了代码并得到了我想要的东西。发布它以防将来有人寻找类似的东西。
衷心感谢所有花时间帮助我的人。
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
另一种方法是将电子邮件项目限制为特定日期，在此示例中。我最近刚用过这个方法，效果很好。反转排序也很容易，尽管我也喜欢“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 限制的另一个问题，我一直错过了：
我正在尝试制作一个 excel 宏，以便将电子邮件从我的 outlook 文件夹导入到指定日期范围内的 excel 文件（对于收到的电子邮件）。这个过程必须定期进行。因此，我需要继续在 excel sheet.
中的现有电子邮件下方添加电子邮件我成功了，但是，我的日期范围似乎不起作用。如果我只添加 'From date'，它会工作并导入从指定的 'From date' 到最后收到的电子邮件的所有电子邮件。但是如果我指定了一个日期范围，那么宏就根本不起作用，尽管它没有显示任何错误/调试。它只是告诉我导入已完成。在我的 sheet 单元格 L1 中包含 'From date' 并且单元格 L2 包含 'To date'.
我该如何纠正？
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。现在代码选择日期范围，忽略晚于 16/08/2021 的电子邮件，但是，它不会获取日期为 16/08/2021 的电子邮件。它仅在 15/08/2021 之前提取电子邮件。收件箱按照“最新优先”排序，有日期为 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 的截止日期为 (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
这里是选择代码逻辑
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
如果您要退出基于日期的处理循环，您最好按照您期望的相同顺序对我们的项目进行排序。
改变
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
在这个平台专家的帮助下，我修改了代码并得到了我想要的东西。发布它以防将来有人寻找类似的东西。
衷心感谢所有花时间帮助我的人。
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
另一种方法是将电子邮件项目限制为特定日期，在此示例中。我最近刚用过这个方法，效果很好。反转排序也很容易，尽管我也喜欢“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 限制的另一个问题，我一直错过了：