CODEWITHSUNDEEP
vbadatefilteroutlookrestriction
sancho.s ReinstateMonicaCellio
sancho.s ReinstateMonicaCellio

Reputation: 15561

Outlook VBA get all AppointmentItems in a Date range and return them as a Collection

I mean to get all AppointmentItems in a Date range and return them as a Collection. This is the function I wrote

Function GetAppointmentItemsDatesRange(ByVal dstart As Date, ByVal dend As Date) As Outlook.Items
'=======================================================
' Get all AppointmentItem in a range of dates
'=======================================================

    Dim oCalendar As Outlook.Folder
    Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
    
    Dim objItems As Outlook.Items
    Dim objRestrictedItems As Outlook.Items
    
    Set objItems = oCalendar.Items
    objItems.IncludeRecurrences = True
    'objItems.IncludeRecurrences = False
    objItems.Sort "[Start]"

    Dim filterRange As String
    filterRange = "[Start] >= " & Chr(34) & Format(dstart, "dd/mm/yyyy hh:mm AM/PM") & Chr(34) & " AND " & _
                  "[End] <= " & Chr(34) & Format(dend, "dd/mm/yyyy hh:mm AM/PM") & Chr(34)    ' <-- Line #1'
    Set objRestrictedItems = objItems.Restrict(filterRange)
    Debug.Print "Filter : " & filterRange
    
    Dim oItem As Outlook.AppointmentItem
    Dim iIt As Long
    Dim nItFilter As Long, nIt As Long
    nItFilter = objRestrictedItems.Count
    nIt = 0
    Debug.Print nItFilter & " total items"
    For Each oItem In objRestrictedItems
        If (Not (oItem Is Nothing)) Then
            nIt = nIt + 1
            Debug.Print oItem.Start & "-" & oItem.End    ' <-- Line #2'
        End If
    Next oItem
    Debug.Print nIt & " net items"

    Set GetAppointmentItemsDatesRange = objRestrictedItems

End Function

I tried with both .IncludeRecurrences = True and False. This is the output I get.

False:

Filter : [Start] >= "07/11/2020 05:30 PM" AND [End] <= "07/11/2020 06:15 PM"
9 total items
31/12/2015 9:00:00-31/12/2015 9:00:00
31/01/2017 15:30:00-31/01/2017 15:30:00
18/03/2020 12:00:00-18/03/2020 16:00:00
13/04/2020 8:45:00-13/04/2020 9:00:00
09/09/2020 11:00:00-09/09/2020 12:00:00
28/09/2020 14:45:00-28/09/2020 18:00:00
01/10/2020 13:30:00-01/10/2020 15:00:00
07/11/2020 17:30:00-07/11/2020 17:45:00
07/11/2020 17:45:00-07/11/2020 18:15:00
9 net items

True:

Filter : [Start] >= "07/11/2020 05:30 PM" AND [End] <= "07/11/2020 06:15 PM"
2147483647 total items
07/11/2020 17:30:00-07/11/2020 17:45:00
07/11/2020 17:45:00-07/11/2020 18:15:00
2 net items

So I identify two problems to get to my result:

  1. The outputs of Line #1 and Line #2 seem inconsistent, in both cases. I do not understand why are the first 7 items not filtered out in the False case, even if I can get rid of them with True. And I do not understand what are those too many Nothing items in the True case.
  2. I do not know hot to define a Collection where I can add the items that satisfy the If (Not (oItem Is Nothing)) condition, so I can return it upon exiting for the caller to use.

What is the explanation for the questions? How can I achieve my goal?

Upvotes: 0

Views: 781

Answers (1)

niton
niton

Reputation: 9179

Since you found a way to identify the required items, add them to a new collection. Pass that collection to the caller.

Option Explicit

Sub collNotNothingItems()

Dim dtSt As Date
Dim dtEn As Date

Dim notNothingItems As Collection

Dim i As Long

dtSt = Date - 7
dtEn = Date

Set notNothingItems = GetAppointmentItemsDatesRange(dtSt, dtEn)

Debug.Print notNothingItems.count & " in the collection passed to the caller"

For i = 1 To notNothingItems.count
    With notNothingItems(i)
        Debug.Print .Start & "-" & .End
    End With
Next

End Sub


Function GetAppointmentItemsDatesRange(ByVal dstart As Date, ByVal dend As Date) As Collection
'=======================================================
' Get all AppointmentItem in a range of dates
'=======================================================

    Dim oCalendar As Folder
    
    Dim objItems As Items
    Dim objRestrictedItems As Items
    
    Dim filterRange As String
    
    Dim myItems As Collection
    
    Dim oItem As AppointmentItem
    
    Dim iIt As Long
    Dim nItFilter As Long
    Dim nIt As Long
    
    Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
       
    Set objItems = oCalendar.Items
    objItems.IncludeRecurrences = True
    objItems.Sort "[Start]"

    'filterRange = "[Start] >= " & Chr(34) & Format(dstart, "dd/mm/yyyy hh:mm AM/PM") & Chr(34) & " AND " & _
                  "[End] <= " & Chr(34) & Format(dend, "dd/mm/yyyy hh:mm AM/PM") & Chr(34)
                  
    filterRange = "[Start] >= " & Chr(34) & Format(dstart, "yyyy-mm-dd hh:mm AM/PM") & Chr(34) & " AND " & _
                  "[End] <= " & Chr(34) & Format(dend, "yyyy-mm-dd hh:mm AM/PM") & Chr(34)
    
    Debug.Print "filterRange: " & filterRange
    
    Set objRestrictedItems = objItems.Restrict(filterRange)
    
    nItFilter = objRestrictedItems.count
    Debug.Print nItFilter & " total items"
    
    nIt = 0
    
    Set myItems = New Collection
    
    For Each oItem In objRestrictedItems
        If (Not (oItem Is Nothing)) Then
            nIt = nIt + 1
            Debug.Print oItem.Start & "-" & oItem.End
            
            myItems.Add oItem
            
        End If
    Next oItem
    
    Debug.Print nIt & " net items"
    
    Set GetAppointmentItemsDatesRange = myItems

End Function

Upvotes: 1

Related Questions