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

Question

我想在Excel中使用VBA宏将共享Outlook日历中的约会从Excel中提取到Excel中。代码失败我是否尝试定义objOwner和olFolderCalendar如任一对象或Outlook.Recipient/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("test@test.com") 

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，但是在上下文你正在尝试做你想做的Enumeration值olFolderCalendar的其中有的值。

我已经整理了代码，并做了一些优化以使代码更快，并添加了一个基本的错误处理程序。伟大的第一篇文章:)

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

你必须改变：

Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)

与此：

Set olFolder = olNS.GetDefaultFolder(9)