在特定时间范围内查看电子邮件

Question

我需要在特定时间范围内检查文件夹中的项目。

我的代码遍历了指定文件夹中的所有邮件，但是该文件夹有数千封邮件，所以需要很长时间。

如何只查看从 3/16/2015 12:00PM 到 3/16/2015 2:00PM 的邮件？

这是我的：

Sub ExportToExcel()   
     
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim workbookFile As String
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object

     'Folder path and file name of an existing Excel workbook
     
    workbookFile = "C:\Users\OutlookItems.xls"
     
     'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
     
     'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, _
        "Error"
        Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, _
        "Error"
        Exit Sub
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, _
        "Error"
        Exit Sub
    End If
     
    ' Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    Set wkb = appExcel.Workbooks.Open(workbookFile)
    Set wks = wkb.Sheets(1)
    wks.Activate
    appExcel.Application.Visible = True
    Set rng = wks.Range("A1")
     
     'Copy field items in mail folder.
     
    For Each itm In fld.Items
        If itm.Class = Outlook.OlObjectClass.olMail Then
            Set msg = itm
            If InStr(msg.Subject, "Error in WU_Send") > 0 And DateDiff("h", msg.SentOn, Now) <= 2 Then
                rng.Offset(0, 4).Value = msg.Body
                Set rng = rng.Offset(1, 0)
            End If
        End If
    Next     
End Sub

问题出在这部分：

    For Each itm In fld.Items
        If itm.Class = Outlook.OlObjectClass.olMail Then
            Set msg = itm
            If InStr(msg.Subject, "Error in WU_Send") > 0 And DateDiff("h", msg.SentOn, Now) <= 2 Then

如何在指定时间查看电子邮件？

Answer 1

您可以将行更改为：

If InStr(msg.Subject, "Error in WU_Send") > 0 And msg.SentOn > "03/16/2015 12:00 PM" AND msg.SentOn < "03/16/2015 2:00 PM" Then

Answer 2

您需要使用项目 class 的 Find/FindNext or Restrict 方法，而不是遍历文件夹中的所有项目。例如：

Sub DemoFindNext() 
 Dim myNameSpace As Outlook.NameSpace 
 Dim tdystart As Date 
 Dim tdyend As Date 
 Dim myAppointments As Outlook.Items 
 Dim currentAppointment As Outlook.AppointmentItem 

 Set myNameSpace = Application.GetNamespace("MAPI") 
 tdystart = VBA.Format(Now, "Short Date") 
 tdyend = VBA.Format(Now + 1, "Short Date") 
 Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items 
 Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """") 
 While TypeName(currentAppointment) <> "Nothing" 
   MsgBox currentAppointment.Subject 
   Set currentAppointment = myAppointments.FindNext 
 Wend 
End Sub

有关详细信息和示例代码，请参阅以下文章：

此外，您可能会发现应用程序 class 的 AdvancedSearch 方法很有帮助。下面列出了使用 AdvancedSearch 方法的主要好处：

搜索在另一个线程中执行。您不需要手动运行另一个线程，因为 AdvancedSearch 方法运行会自动在后台运行它。
可以在任何位置（即超出某个文件夹的范围）搜索任何项目类型：邮件、约会、日历、便笺等。 Restrict 和 Find/FindNext 方法可以应用于特定的项目集合（请参阅 Outlook 中文件夹 class 的项目属性）。
完全支持 DASL 查询（自定义属性也可用于搜索）。您可以在 MSDN 的过滤文章中阅读更多相关信息。为了提高搜索性能，如果为商店启用了即时搜索，则可以使用即时搜索关键字（请参阅商店 class 的 IsInstantSearchEnabled 属性）。
您可以随时使用搜索的停止方法停止搜索过程 class。

Answer 3

指定时间段。

Option Explicit

Sub RestrictTimePeriod()

Dim nms As Namespace
Dim fld As folder   ' Subsequent to 2003 otherwise MAPIFolder
Dim msg As MailItem

Dim filterCriteria As String
Dim filterItems As Items
Dim i As Long

Dim start
Dim dif

Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

If Not fld Is Nothing Then

    start = Now
    Debug.Print start

    ' http://www.jpsoftwaretech.com/use-filters-to-speed-up-outlook-macros/
    filterCriteria = "[ReceivedTime] > " & QuoteWrap("2015-03-16 12:00 PM") & _
                 " And [ReceivedTime] < " & QuoteWrap("2015-03-17 2:00 PM")

    Set filterItems = fld.Items.Restrict(filterCriteria)

    For i = filterItems.count To 1 Step -1
        Set msg = filterItems.Item(i)
        Debug.Print msg.Subject
    Next

End If

ExitRoutine:
    Set nms = Nothing
    Set msg = Nothing
    Set filterItems = Nothing

Debug.Print Now
dif = (Now - start) * 86400
Debug.Print dif
Debug.Print "Done."

End Sub

Function QuoteWrap(stringToWrap As String, _
    Optional charToUse As Long = 39) As String
' http://www.jpsoftwaretech.com/use-filters-to-speed-up-outlook-macros/
' use 34 for double quotes, 39 for apostrophe
  QuoteWrap = Chr(charToUse) & stringToWrap & Chr(charToUse)
End Function

在特定时间范围内查看电子邮件

Check e-mails in specific time frame

email

outlook

vba