通过 Outlook VBA 仅获取今天的约会 [英] Get only today's appointments through Outlook VBA

问题描述

我正在提取今天所有 Outlook 帐户中的所有约会.

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

我遇到了在这篇文章中遇到的同样问题这里，但我正在尝试通过 VBA 来做到这一点.

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

我不明白 Powershell 代码如何在答案中过滤掉重复出现的约会，因为在我的 VBA 尝试中，我得到了整周的约会.

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

编辑#1:根据尤金的回答，我将 strFilter 更新为无济于事

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'

另外，我也把 IncludeReccurence 放在第一位，结果没有变化

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

编辑#2将 for each 循环替换为使用 GetFirst() 和 GetNext() 无济于事

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

编辑#3:我创建了一个 VB.NET 应用程序，我在其中使用了答案中的链接中提供的函数，逐字逐句，并且按预期工作.因此，也许 VBA 中存在问题(不太可能)，或者我在 VBA 脚本中遗漏了一些小问题?

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?

编辑#4:问题一直在我的逻辑中.项目需要按升序排序.感谢 Eugene 和 niton

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

推荐答案

OP 留下了一条评论，表明 Restrict 是有效的.

The OP left a comment to indicate Restrict is valid.

"... IncludeRecurrences 文档的链接 ... 提到 .Sort 需要按升序完成

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

.Restrict 可能不适合此任务.

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

一个使用 .Find 的例子.

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

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

这篇关于通过 Outlook VBA 仅获取今天的约会的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！