Outlook Naptárból napi események exportálása excelbe? Excel VBA-t használok.

A default folder exportálása megy, probléma azzal van ha van egy shared foldert akarok exportálni, akkor mindig Run Time Error -2147221246 (80040102) kapok.(MAPI_E_NO_SUPPORT)

A kód:

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 myRecipient As Object

Dim myAdress_1 As String

Dim myAdress_2 As String

Dim myAdress_3 As String

Dim d As Date

d = "01.01.2016"

myAdress_1 = "xy1@blabla.com"

myAdress_2 = "xy2@bla.com"

myAdress_3 = "xy3@bla.com"

Set olApp = CreateObject("Outlook.Application")

Set olNS = olApp.GetNamespace("MAPI")

Set myRecipient = olNS.CreateRecipient(myAdress_2)

myRecipient.Resolve

Set olFolder = olNS.GetSharedDefaultFolder(myRecipient, 9)

Range("A1:D1").Value = Array("Subject", "Start", "End", "Location")

NextRow = 2

For Each olApt In olFolder.Items

If (olApt.Start > d) Then

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

End If

Next olApt

Set olApt = Nothing

Set olFolder = Nothing

Set olNS = Nothing

Set olApp = Nothing

Columns.AutoFit

End Sub

Outlookban 5 emailcím van megadva, ebből 2-t arra használunk hogy a szabadságokat vagy az éppen nem elérhetőségeket bevisszük és akkor midnen kolléga látja ki mikor hiányzik.

Bármelyik emailcímet defaulttá tudom tenni és akkor scriptem működik. (mindegy hogy GetSharedDefaultFolder vagy GetDefaultFolder, nem látok futásbeli különbséget)

De a lényeg az lenne hogy egy nemdefault folderből exportáljak. (egyébként mindig outlook újraindítás kell, plussz ha valakinek odaadom akódot még azt is el kell magyaráznom hogy állítja át defaultra.)

Valami ötlet? :(