使用 excel VBA 获取 Outlook 电子邮件项目，按日期限制

Question

我编写了以下代码，当我想在我的 Excel 表中提取 Outlook 电子邮件项目时，它工作得很好，但当我想获取在某个日期收到的电子邮件时它不起作用：

Sub getMail()
   Dim i As Long
    Dim arrHeader As Variant
    
    Dim olNS As Namespace
    Dim olInboxFolder As MAPIFolder
    Dim olItems As Items
    Dim olItem As Variant
    
    Set olNS = GetNamespace("MAPI")
    Set olInboxFolder = olNS.PickFolder 'Pick folder
    Set olItems = olInboxFolder.Items
      

    
    arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
    ThisWorkbook.Worksheets("Output").Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
    
    ActiveSheet.Range("E2", Range("E2").End(xlDown)).NumberFormat = "mm/dd/yyyy h:mm AM/PM"
    
    
    
    i = 1
    
sFilter = InputBox("Enter Date")
    
FilterString = "[ReceivedTime] > sFilter "
    
For Each olItem In olItems.Restrict(FilterString)
        ' MailItem
        If olItem.Class = olMail Then
        Set mi = olItem
        Debug.Print mi.ReceivedTime
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).ReceivedTime
                If olItems(i).SenderEmailType = "SMTP" Then
                    ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
                ElseIf olItems(i).SenderEmailType = "EX" Then
                    ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = olItems(i).Sender.GetExchangeUser.PrimarySmtpAddress
                    End If
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "D").Value = olItems(i).Body
            
            i = i + 1
            On Error Resume Next
           
            
        ' ReportItem
        ElseIf olItem.Class = olReport Then
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).CreationTime
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = _
            olItems(i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")  'PR_DISPLAY_TO
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
            i = i + 1
        End If
        
  
Next olItem
    
    ThisWorkbook.Worksheets("Output").Cells.EntireColumn.AutoFit
    
    MsgBox "Export complete.", vbInformation

    Set olItems = Nothing
    Set olInboxFolder = Nothing
    Set olNS = Nothing
End Sub

例如，我想获取从 08/16/2020 日期开始发送的所有电子邮件，或者获取某个日期范围内的所有电子邮件。

Answer 1

Private Sub getMail_InputBoxDate()
    
    Dim olNS As namespace
    Dim olFilterFolder As Folder
    
    Dim olItems As Items
    Dim olItem As Object
    Dim mi As mailItem
    
    Dim filterString As String
    
    Dim sDate1 As String
    Dim filterString1 As String
    
    Dim sDate2 As String
    Dim filterString2 As String
    
    Dim olItemsRes As Items
    
    Set olNS = GetNamespace("MAPI")
    
    Set olFilterFolder = olNS.PickFolder 'Pick folder
    
    Set olItems = olFilterFolder.Items
    olItems.Sort "[ReceivedTime]", True
    
    Debug.Print vbCr & "olItems.Count: " & olItems.Count
    
    sDate1 = InputBox("Enter Start Date", , "2020-09-14")
    'Debug.Print sDate1
    sDate1 = Format(sDate1 & " 00:00 AM", "DDDDD HH:NN")
    Debug.Print vbCr & "sDate1: " & sDate1
    
    ' Single quotes around variable.
    filterString1 = "[ReceivedTime] >= '" & sDate1 & "'"
    Debug.Print " filterString1: " & filterString1
    
    Set olItemsRes = olItems.Restrict(filterString1)
    Debug.Print " olItemsRes.Count: " & olItemsRes.Count
    
    sDate2 = InputBox("Enter date, one day after desired range.", , "2020-09-15")
    'Debug.Print sDate2
    sDate2 = Format(sDate2 & " 00:00 AM", "DDDDD HH:NN")
    Debug.Print vbCr & "sDate2: " & sDate2
    
    ' With single quotes around variable.
    filterString2 = "[ReceivedTime] < '" & sDate2 & "'"
    Debug.Print " filterString2: " & filterString2
    
    ' Option 1 - Restrict the previously restricted items
    Set olItemsRes = olItemsRes.Restrict(filterString2)
    Debug.Print " olItemsRes.Count: " & olItemsRes.Count
    
    Debug.Print
    For Each olItem In olItemsRes
        ' MailItem
        If olItem.Class = olMail Then
            Set mi = olItem
            Debug.Print mi.ReceivedTime & " " & mi.Subject
        End If
    Next olItem
    
    ' Option 2 - Combine two working filters into one
    filterString = filterString1 & " AND " & filterString2
    Debug.Print vbCr & "filterString combined: " & filterString
    ' Restrict the original items once
    Set olItemsRes = olItems.Restrict(filterString)
    Debug.Print "olItemsRes.Count: " & olItemsRes.Count
    Debug.Print
    For Each olItem In olItemsRes
        ' MailItem
        If olItem.Class = olMail Then
            Set mi = olItem
            Debug.Print mi.ReceivedTime & " " & mi.Subject
        End If
    Next olItem
    
    Debug.Print vbCr & "Done."

End Sub

这是Restrict Outlook Items by Date，但会增加用户输入日期的时间。