从共享的Outlook日历中提取约会至Excel

Question

我试图从共享的Outlook日历中提取约会，以使用Excel中的VBA宏来提取Excel。代码是否尝试定义 objowner 和 olfolderCalendar 作为对象或 OUTLOOK.RECIPIENT /strong>/Outlook.folder 用于 getSharedDefaultFolder 方法。

我获得运行时错误'13'：键入不匹配在以下行上错误：

Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)

我在做什么错？

Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim objOwner As Object
Dim olFolderCalendar As Object
Dim NextRow As Long
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("[e-mail]")
objOwner.Resolve
If objOwner.Resolved Then
    MsgBox objOwner.Name
    Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
Range("A1:D1").Value = Array("Subject", "Start", "End", "Location")
NextRow = 2
For Each olApt In olFolder.Items
    Cells(NextRow, "A").Value = olApt.Subject
    Cells(NextRow, "B").Value = olApt.Start
    Cells(NextRow, "C").Value = olApt.End
    Cells(NextRow, "D").Value = olApt.Location
    NextRow = NextRow + 1
Next olApt
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Columns.AutoFit
End Sub

Answer 1

欢迎来到stackoverflow！

您问题的原因是使用 olFolderCalendar的对象，但是在上下文中，您想要的是olfoldercalendar的 Enumeration值，该值的值为 9 。

我已经整理了代码，并进行了一些优化以使该代码更快，并添加了一个基本的错误处理程序。很棒的第一篇文章：）

Option Explicit
Public Sub ListAppointments()
On Error GoTo ErrHand:
    Application.ScreenUpdating = False
    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9
    Dim olApp       As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = olApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("emailAddressHERE")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    objOwner.Resolve
    If objOwner.Resolved Then 
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
    end if
    ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")
    'Ensure there at least 1 item to continue
    If olFolder.Items.Count = 0 Then Exit Sub
    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)
    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next
    For Each olApt In olFolder.Items
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        NextRow = NextRow + 1
    Next
    On Error GoTo 0
    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)
    'AutoFit
    ws.Columns.AutoFit
cleanExit:
    Application.ScreenUpdating = True
    Exit Sub
ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

Answer 2

这是代码@Ryan Wildry为您写的，以开始和结束日期输入，以防您要在指定的时间段内导出它。您需要添加以下行：

Dim FromDate As Date
    Dim ToDate As Date
   FromDate = InputBox("Enter the start date (format: yyyy/mm/dd)")
   ToDate = InputBox("Enter the end date(format: yyyy/mm/dd)")
   For Each olApt In olFolder.Items
    If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        NextRow = NextRow + 1
        Else
        End If
    Next
    On Error GoTo 0

Answer 3

您必须更改：

Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)

与此：

Set olFolder = olNS.GetDefaultFolder(9)