如何从 Excel 中的给定日期获取 Outlook 约会

Question

我想在 MessageBox 中显示给定日期的 Outlook 日历约会。 不幸的是，我使用的代码没有显示今天的任何约会。 如果我将代码更改为sfilter = "[Start] >= '" & startDate & "' "那么我会得到今天的约会以及其他日期的所有未来约会。 我只想显示指定日期的约会。

日期选择来自名为cmDates.srtDate.Value的UserForm

sFilter是我在整个代码中使用的保持日期过滤器的变量

代码

Public Function getOutlookAppointments() As String
    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oAppointments         As Object
    Dim oFilterAppointments   As Object
    Dim oAppointmentItem      As Object
    Dim bOutlookOpened        As Boolean
   ' Dim rslt                  As String
    Dim sfilter               As String
    Dim startDate             As Date
    Dim displayText As String
    Dim start As Date
    Const olFolderCalendar = 9

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If Err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
        bOutlookOpened = False    'Outlook was not already running, we had to start it
    Else
        bOutlookOpened = True    'Outlook was already running
    End If
    On Error GoTo Error_Handler
    DoEvents

    Set oNS = oOutlook.GetNamespace("MAPI")
    Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
    startDate = cmDates.srtDate.value
    'Apply a filter so we don't waste our time going through old stuff if we don't need to.
    sfilter = "[Start] = '" & startDate & "' "
    Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)

    For Each oAppointmentItem In oFilterAppointments
     getOutlookAppointments = getOutlookAppointments & oFilterAppointments.Count & " appointment(s) found" & vbCrLf & vbCrLf & oAppointmentItem.Subject & vbCrLf & oAppointmentItem.start & vbCrLf & oAppointmentItem.End & vbCrLf & vbCrLf

      'displayText = displayText & oAppointmentItem.Subject

    Next

    MsgBox prompt:=getOutlookAppointments, _
    Title:="Appointments for"


    If bOutlookOpened = False Then    'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
    End If

Error_Handler_Exit:
    On Error Resume Next
    Set oAppointmentItem = Nothing
    Set oFilterAppointments = Nothing
    Set oAppointments = Nothing
    Set oNS = Nothing
    Set oOutlook = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetFutureOutlookEvents" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit

    outlookDates = False
End Function

Answer 1

您的限制应该有两部分 - Start > today's midnight和Start < tomorrow's midnight 。 你只有第一部分。

另请记住，如果您想要重复活动的实例（而不仅仅是主约会），则需要使用Items.IncludeRecurrences属性 - 请参阅https://docs.microsoft.com/en-us/office/vba /api/outlook.items.includerecurrences

Answer 2

有几个方面：

1. 要从满足预定义条件的文件夹中检索所有 Outlook 约会项目，您需要按升序对项目进行排序并将IncludeRecurrences设置为 true。 如果您在使用Restrict方法之前不这样做，您将无法捕捉重复约会！
2. 如果您设置了IncludeRecurrences属性，Microsoft 不建议使用Count属性。 Count属性可能会返回意外结果并导致无限循环。
3. 尽管日期和时间通常以Date格式存储，但Find和Restrict方法要求将日期和时间转换为字符串表示形式。 要确保日期格式符合 Microsoft Outlook 的要求，请使用 VBA 中提供的Format功能。 因此，您必须以 Outlook 理解的格式指定日期。

     Format(youDate, "ddddd h:nn AMPM")

例如，这是一个示例 VB.NET 代码：

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

您可能会发现以下文章很有帮助：

• 如何：在 Outlook 中使用 Restrict 方法获取日历项目
• 如何：使用 Find 和 FindNext 方法检索 Outlook 日历项目