在指定的日期范圍內將 Outlook 封電子郵件導入到 Excel

Question

我正在嘗試制作一個 excel 宏，以將電子郵件從我的 outlook 文件夾導入指定日期范圍內的 excel 文件（對於收到的電子郵件）。 這個過程必須定期進行。 因此，我需要 go 在 excel 工作表中的現有電子郵件下方添加電子郵件。

我讓它工作，但是，我的日期范圍似乎不起作用。 如果我只添加“開始日期”，它會工作並導入從指定的“開始日期”到最后收到的所有電子郵件 email。但是如果我指定一個日期范圍，那么宏根本不起作用，盡管它不顯示任何錯誤/調試。 它只是告訴我導入已完成。 在我的工作表中，單元格 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。 現在代碼選擇日期范圍，忽略晚於 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

Answer 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

Answer 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

Answer 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

Answer 4

另一種方法是將 email 項限制為特定日期，在此示例中。 我最近剛用過這個方法，效果很好。 反轉排序也很容易，盡管我也喜歡“OutlookItems.Sort [ReceivedTime]，true '按升序排序”方法。

Items.Restrict 方法 (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