Question

我需要一个VBA outlook宏来检查特定时间范围内文件夹中的项目。目前我的代码遍历指定文件夹中的所有邮件，但这不是一个选项，因为该文件夹有数千封邮件，因此宏运行需要永远，任何想法，如何让脚本检查邮件仅来自例如：2015年3月16日中午12:00至2015年3月16日下午2:00，并且不检查该时间范围内的任何电子邮件？

这就是我现在所拥有的：

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

您需要使用Items类的Find / FindNext或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

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

另外，您可能会发现Application类的AdvancedSearch方法很有帮助。下面列出了使用AdvancedSearch方法的主要好处：

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

Answer 2

您可以将该行更改为：

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

Outlook仅在特定时间范围内检查电子邮件

3 个答案: