CODEWITHSUNDEEP
vbaemailoutlook
user3636021
user3636021

Reputation: 17

Check e-mails in specific time frame

I need to check items in a folder in a specific time frame.

My code goes through all the mails in the specified folder, but the folder has thousands of mails, so it takes forever.

How do I check the mails only from, for example, 3/16/2015 12:00PM to 3/16/2015 2:00PM?

This is what I have:

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

The problem lies in this part:

    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

How do I look at e-mails between specified hours?

Upvotes: 0

Views: 13508

Answers (3)

niton
niton

Reputation: 9179

This specifies the time period.

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

Upvotes: 0

Eugene Astafiev
Eugene Astafiev

Reputation: 49395

You need to use the Find/FindNext or Restrict methods of the Items class instead of iterating through all items in the folder. For example:

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

See the following articles for more information and sample code:

Also you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method are listed below:

  • The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
  • Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
  • Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
  • You can stop the search process at any moment using the Stop method of the Search class.

Upvotes: 1

OpiesDad
OpiesDad

Reputation: 3435

You could just change the line to:

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

Upvotes: 0

Related Questions