从共享 Outlook 日历中提取约会到 Excel [英] Extracting appointments from shared Outlook calendar to Excel

问题描述

我正在尝试使用 Excel 中的 VBA 宏将约会从共享的 Outlook 日历提取到 Excel.无论我尝试将 objOwner 和 olFolderCalendar 定义为 Object 还是 Outlook.Recipient/，代码都会失败Outlook.Folder 用于 GetSharedDefaultFolder 方法.

I am trying to extract appointments from a shared Outlook calendar to Excel using a VBA macro in Excel. The code fails whether I try to define objOwner and olFolderCalendar as either Object or Outlook.Recipient / Outlook.Folder for use in the GetSharedDefaultFolder method.

我在以下行收到运行时错误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

推荐答案

欢迎使用 StackOverflow！

Welcome to StackOverflow!

您的问题的原因是为 olFolderCalendar 使用了一个对象，但是在您尝试执行的操作的上下文中，您需要一个具有值的 olFolderCalendar 的 Enumeration 值9.

The cause of your issue was using an object for olFolderCalendar, however in context for what you are trying to do you want an Enumeration value of olFolderCalendar which has a value of 9.

我整理了代码，并进行了一些优化以使此代码更快，并添加了一个基本的错误处理程序.很棒的第一篇文章:)

I've tidied up the code, and made a few optimization to make this code faster, and added a basic error handler. Great first post :)

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

这篇关于从共享 Outlook 日历中提取约会到 Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！