Import Shared Group Outlook Calendar Appointments to Excel

Question

I want to import the appointments in a shared group Outlook calendar to Excel.

I used the GetSharedDefaultFolder but I received the following error:

You can not open the mailbox because this address book entry does not match an email user.

Sub ResolveName()
    ' déclaration des variables
    Dim outlookApp As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient
    Dim CalendarFolder As Outlook.folder
    Dim calendarApp As Outlook.AppointmentItem
    Dim calendarItem As Outlook.Items
    Dim i As Long
        
    Set outlookApp = New Outlook.Application
    Set myNamespace = outlookApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient("dp-TECCR-FormationdesrepartiteursCCRediteurs@hydro.qc.ca")
    i = 2
        
    myRecipient.Resolve
    Range("A1:D1").Value = Array("Subject", "from", "date", "location")
    If myRecipient.Resolved Then
        Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
        For Each calendarApp In CalendarFolder.Items
            Cells(i, 1).Value = calendarItem.Subject
            Cells(i, 2).Value = calendarItem.Start
            Cells(i, 3).Value = calendarItem.End
            Cells(i, 4).Value = calendarItem.Location
            Cells(i, 5).Value = calendarItem.MeetingStatus
            i = i + 1
        Next
    End If
        
    Set outlookApp = Nothing
    Set myNamespace = Nothing
    Set myRecipient = Nothing
    Set CalendarFolder = Nothing
    Set calendarItem = Nothing
End Sub

Answer 1

Resolve does nothing when you use an email address.

Use display name / other name property in CreateRecipient if you want to follow up with a useful If myRecipient.Resolved Then .

Option Explicit

Sub ResolveName()
    ' déclaration des variables
    Dim outlookApp As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient
    Dim CalendarFolder As Outlook.Folder
    Dim calendarApp As Outlook.AppointmentItem
    Dim calendarItem As Outlook.Items
    Dim i As Long

    Set outlookApp = New Outlook.Application
    Set myNamespace = outlookApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient("nothingvalid@hydro.qc.ca")
    i = 2

    myRecipient.Resolve
    'Range("A1:D1").Value = Array("Subject", "from", "date", "location")
    If myRecipient.Resolved Then
        Debug.Print "Anything that looks like an email address will Resolve."
        Debug.Print "Use display name / other name property."
        'Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
        'For Each calendarApp In CalendarFolder.Items
        '    Cells(i, 1).Value = calendarItem.Subject
        '    Cells(i, 2).Value = calendarItem.Start
        '    Cells(i, 3).Value = calendarItem.End
        '    Cells(i, 4).Value = calendarItem.Location
        '    Cells(i, 5).Value = calendarItem.MeetingStatus
        '    i = i + 1
       ' Next
    End If

    Set outlookApp = Nothing
    Set myNamespace = Nothing
    Set myRecipient = Nothing
    Set CalendarFolder = Nothing
    Set calendarItem = Nothing
End Sub