使用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

這是按日期限制 Outlook 項目，但會向用戶輸入日期添加時間。