问将共享组Outlook日历约会导入Excel

EN

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