如何在 Excel 中使用 vba 从 Outlook 日历中获取存档的会议

Question

我正在处理 Excel 中的 vba 宏。 Outlook 日历中的所有会议（在给定时间段内）都被读取并写入新表中。

除存档会议外，一切正常。存档的会议有一些奇怪的属性，这些属性与未存档的会议的属性不匹配。这会导致运行时错误。

我已尝试取消归档每个会议。在我这样做之后它工作了，但由于其他人想使用我的宏，它也应该适用于存档的会议。

我确信只有在您尝试读出存档会议时才会出现问题，因为我更改了代码以跳过错误，并且每个非存档会议的行为都应如此。

我在互联网上找不到有同样问题的人，所以我在这里问这个问题。

'Here I read out of the Oulook calendar 

'---------------------------------------------------'

    'Create filter to restrict meetings to the start/end date

    '---------------------------------------------------'

    strRestriction = "[End] >= '" & _
    Format$(startDate, "dd/mm/yyyy hh:mm ") & "' AND [Start] <= '" & Format$(endDate, "dd/mm/yyyy hh:mm ") & "'"
    Set outlookCalendar = outlook.GetNamespace("MAPI").GetDefaultFolder(9)
    Set calendarItems = outlookCalendar.items
    calendarItems.IncludeRecurrences = True
    calendarItems.Sort "[Start]"
    nextRow = 1
    Set itemsInDateRange = calendarItems.Restrict(strRestriction)

'Here I write into the excel sheet 
For Each entry In itemsInDateRange

    With Sheets(sheetToWriteIn)
        nextRow = nextRow + 1
        sumInMinutes = sumInMinutes + durationOfOneMeeting ' summs every meeting up to return a sum at the end of the programm
        .Cells(nextRow, "D").Value = durationOfOneMeeting
        .Cells(nextRow, "A").Value = entry.Subject
        .Cells(nextRow, "B").Value = entry.start 'The error ocures here or at entry.start
        .Cells(nextRow, "C").Value = entry.End
        .Cells(nextRow, "E").Value = entry.Location
        End If
    End With
Next

当我尝试从存档的会议中获取开始日期（这对于“正常”会议非常有效）时，我得到：

Object does not support property

或

function Runtime error 438

Answer 1

不妨试试看：

Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = CDate("08/25/2017")
    ToDate = Now()

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
    NextRow = 2

    With Sheets("Sheet1") 'Change the name of the sheet here
        .Range("A1:G1").Value = Array("Project", "Date", "Time spent", "Location" , "Categories" , "Start Hour" , "End Hour")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "D").Value = olApt.Location
                .Cells(NextRow, "E").Value = olApt.Categories
                .Cells(NextRow, "F").Value = olApt.Start
                .Cells(NextRow, "G").Value = olApt.End
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

输出：

Answer 2

首先，要从满足预定义条件的文件夹中检索所有 Outlook 约会项目，您需要按升序排列 sort 并将 IncludeRecurrences 设置为 true。如果您在使用 Find 或 Restrict 方法之前不这样做，您将不会赶上定期约会！

其次，如果您设置了 IncludeRecurrences 属性，Microsoft 不建议使用 Count 属性。 Count 属性可能会返回意外结果并导致无限循环。

第三，我建议使用 do/while 或 foreach 循环来迭代找到的项目。不能使用 for 循环，因为 Items 类的 Count 属性可能会返回意外结果。