Get only today's appointments through Outlook VBA

问题

I am extracting all appointments across all Outlook accounts for today.

I am experiencing the same issue encountered in this post here, but I am trying to do this through VBA.

Originally I managed to get the appointments for today, but it would also return reoccurring meetings that are not taking place today (like in the linked question).

I do not understand how the Powershell code, in the answer, manages to filter out the reoccurring appointments, because in my VBA attempt I get the whole week of appointments.

This is my attempt. I've included the filter where I get the appointments for today as well the reoccurring appointments which do not take place today.

Sub GetAllCalendarAppointmentsForToday()

    Dim olApplication As Outlook.Application
    Dim olNamespace As NameSpace
    Dim olAccounts As Accounts
    Dim olStore As Outlook.Store
    Dim olCalendarFolder As Outlook.Folder
    Dim olCalendarItems As Outlook.Items
    Dim olTodayCalendarItems As Outlook.Items
    Dim strFilter As String
    Dim strFilter2 As String
    
    Set olApplication = CreateObject("Outlook.Application")
    Set olNamespace = olApplication.Session
    Set olAccounts = olNamespace.Accounts
    
    Debug.Print olAccounts.Count
    
    For Each oAccount In olAccounts
        Debug.Print oAccount
        Set olStore = oAccount.DeliveryStore
        Set olCalendarFolder = olStore.GetDefaultFolder(olFolderCalendar)
        
        Set olCalendarItems = olCalendarFolder.Items
        
        olCalendarItems.Sort "[Start]", True
        olCalendarItems.IncludeRecurrences = True
    
        Debug.Print olCalendarItems.Count
        
        'Find your today's appointments
        strFilter = Format(Now, "ddddd")
        strFilter2 = Format(DateAdd("d", 7, Now), "ddddd")
        Debug.Print strFilter
        Debug.Print strFilter2
        
        'strFilter = "[Start] > " & Chr(34) & strFilter & " 00:00" & Chr(34) & " AND [Start] < " & Chr(34) & strFilter & " 00:00" & Chr(34)
        strFilter = "[Start] > " & Chr(34) & strFilter & " 00:00" & Chr(34) & " AND [Start] < " & Chr(34) & strFilter2 & " 00:00" & Chr(34)
        Debug.Print strFilter
        
        Set olTodayCalendarItems = olCalendarItems.Restrict(strFilter)
        
        Debug.Print olTodayCalendarItems.Count
        
        Debug.Print "Begin Print of Appointments"
        For Each objAppointment In olTodayCalendarItems
            Counter = Counter + 1
            Debug.Print Counter & ":" & objAppointment.Subject & " " & objAppointment.Location & " [" & objAppointment.Start & "|" & objAppointment.End & "]"
        Next
        
        Debug.Print vbNewLine
    Next

End Sub

Edit #1: As per Eugene's answer, I updated the strFilter to be this to no avail

strFilter = [Start] <= '07/15/2020 11:59 PM' AND [End] >= '07/15/2020 12:00 AM'

In addition, I put IncludeReccurence first as well and no change in the results

Edit #2 Replaced the for each loop to use GetFirst() and GetNext() to no avail

Set olTodayCalendarItems = olCalendarItems.Restrict(strFilter)
Set olItem = olTodayCalendarItems.GetFirst()
Do While Not olItem Is Nothing
    Set olAppointment = olItem
    counter = counter + 1
    Debug.Print counter & ":" & olAppointment.Subject & " " & olAppointment.Location & " [" & olAppointment.Start & "|" & olAppointment.End & "]"
    Set olItem = olTodayCalendarItems.GetNext()
Loop

Edit #3: I created a VB.NET application where I used the function, provided in the link in the answer, verbatim and it worked as expected. So maybe there is a issue in VBA (unlikely) or I missed something small in my VBA script?

Edit #4: The problem was in my logic all along. Items needed to be sorted in ascending. Thank you to both Eugene and niton

回答1:

The OP left a comment to indicate Restrict is valid.

" ... the link to the docs on IncludeRecurrences ... mentioned that .Sort needs to be done in ascending order"

---

It is possible .Restrict is not appropriate for this task.

An example using .Find.

Items.IncludeRecurrences property(Outlook) https://docs.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences

Sub DemoFindNext()

    ' https://docs.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences

    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
 
    myAppointments.Sort "[Start]"
 
    myAppointments.IncludeRecurrences = True
 
    Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
 
    While TypeName(currentAppointment) <> "Nothing"
        Debug.Print currentAppointment.Subject
        ' MsgBox currentAppointment.Subject
        Set currentAppointment = myAppointments.FindNext
    Wend

End Sub

回答2:

Microsoft doesn’t recommend using the Count property in case you set the IncludeRecurrences property. The Count property may return unexpected results and cause an infinite loop. Read more about that in the How To: Use Restrict method in Outlook to get calendar items article.

Here is a sample VB.NET code where you can see how you can filter appointment items properly:

Imports System.Text
Imports System.Diagnostics
' ...
Private Sub RestrictCalendarItems(folder As Outlook.MAPIFolder)
    Dim dtEnd As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
                                         DateTime.Now.Day, 23, 59, 0, 0)
    Dim restrictCriteria As String = "[Start]<=""" + dtEnd.ToString("g") + """" + _
                                     " AND [End]>=""" + DateTime.Now.ToString("g") + """"
    Dim strBuilder As StringBuilder = Nothing
    Dim folderItems As Outlook.Items = Nothing
    Dim resultItems As Outlook.Items = Nothing
    Dim appItem As Outlook._AppointmentItem = Nothing
    Dim counter As Integer = 0
    Dim item As Object = Nothing
    Try
        strBuilder = New StringBuilder()
        folderItems = folder.Items
        folderItems.IncludeRecurrences = True
        folderItems.Sort("[Start]")
        resultItems = folderItems.Restrict(restrictCriteria)
        item = resultItems.GetFirst()
        Do
            If Not IsNothing(item) Then
                If (TypeOf (item) Is Outlook._AppointmentItem) Then
                    counter = counter + 1
                    appItem = item
                    strBuilder.AppendLine("#" + counter.ToString() + _
                                          " Start: " + appItem.Start.ToString() + _
                                          " Subject: " + appItem.Subject + _
                                          " Location: " + appItem.Location)
                End If
                Marshal.ReleaseComObject(item)
                item = resultItems.GetNext()
            End If
        Loop Until IsNothing(item)
        If (strBuilder.Length > 0) Then
            Debug.WriteLine(strBuilder.ToString())
        Else
            Debug.WriteLine("There is no match in the " _
                             + folder.Name + " folder.")
        End If
    catch ex As Exception
        System.Windows.Forms.MessageBox.Show(ex.Message)
    Finally
        If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
        If Not IsNothing(resultItems) Then Marshal.ReleaseComObject(resultItems)
    End Try
End Sub

来源：https://stackoverflow.com/questions/62923113/get-only-todays-appointments-through-outlook-vba