共有Outlookの予定表からExcelに予定を抽出する

Question

ExcelのVBAマクロを使用して、共有Outlook予定表から予定をExcelに抽出しようとしています。コードは、私はどちらかオブジェクトまたはGetSharedDefaultFolder方法で使用するためのOutlook.Recipient/Outlook.FolderとしてOBJOWNERとolFolderCalendarを定義しようかどうか失敗しました。

私は実行時エラー「13」を取得：次の行の型の不一致エラー：

Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar) 

は私が間違って何をやっているの？これで

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.GetDefaultFolder(9)