Question

我想将共享组Outlook日历中的约会导入Excel。

如下面的代码所示，我使用了对象GetSharedDefaultFolder，但收到以下错误：

您无法打开邮箱，因为此通讯录条目与电子邮件用户不匹配。

请帮助我。

非常感谢。

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

使用电子邮件地址时，“解决”功能不起作用。

如果要跟上有用的CreateRecipient，请在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

将共享的组Outlook日历导入Excel

1 个答案: