我试图使一个excel宏导入电子邮件从我的outlook文件夹到指定日期范围的excel文件(对于收到的电子邮件)。这个过程必须定期进行。因此，我需要继续在excel工作表中添加现有电子邮件下面的电子邮件。
我得到了工作，然而，我的日期范围似乎不起作用。如果我只添加"起始日期"，它会工作并从指定的"起始日期"导入所有电子邮件，直到最后收到的电子邮件。但是，如果我指定一个日期范围，那么宏根本不工作，尽管它不显示任何错误/调试。它只是告诉我导入已经完成。在我的工作表中，单元格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
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年至今的邮件。我想获取电子邮件，我有以下给定的范围。Cell L1有起始日期(28/08/2020)。Cell 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 '按升序排序';方法。
项目。限制方法(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限制的另一个问题，我到现在还没有注意到:对指定日期内的电子邮件使用Restrict方法