在共享日历中创建 Outlook 约会

Question

我设置了以下代码，以便根据我的 Excel 电子表格上的数据在 Outlook 中创建约会。我想在共享日历而不是我自己的默认日历中进行约会。

我要添加的日历是 DTS Streetworks 日历，如下所示 - https://ibb.co/tKXKSPX，但我不知道如何去做。

Sub CoringAdd()

    Dim OL As Outlook.Application, ES As Worksheet, _
    r As Long, i As Long, wb As ThisWorkbook

    Set wb = ThisWorkbook
    Set ES = wb.Sheets("Coring")
    Set OL = New Outlook.Application

    r = ES.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To r
        With ES.Cells(i, 10)
            If .Value = "No" And ES.Cells(i, 7) <> "Yes" Then
                ES.Cells(i, 7) = "Yes"
                With OL.CreateItem(olAppointmentItem)
                    .Subject = "Send reminder email - LBRuT " + ES.Cells(i, 2).Value
                    .Start = ES.Cells(i, 6) + 1 + ES.Cells(i, 8).Value
                    .ReminderSet = True
                    .ReminderMinutesBeforeStart = 60
                    .Body = "£" & ES.Cells(i, 5).Value
                    .Save
                End With
            End If
        End With
    Next i

    Set OL = Nothing
    Set wb = Nothing
    Set ES = Nothing

End Sub

更新：

下面的最新代码，仍然是默认日历。

Sub ResolveName()

Dim OL As Outlook.Application, ES As Worksheet, _
    r As Long, i As Long, wb As ThisWorkbook

    Set wb = ThisWorkbook
    Set ES = wb.Sheets("Licences")
    Set OL = New Outlook.Application
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient
    Dim CalendarFolder As Outlook.MAPIFolder
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
    myRecipient.Resolve


    r = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 5 To r
        With Cells(i, 5)

         If myRecipient.Resolved And .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
    With OL.CreateItem(olAppointmentItem)
                    .Subject = "Test " + ES.Cells(i, 4).Value
                    .Start = ES.Cells(i, 14) + ES.Cells(i, 15).Value
                    .ReminderSet = True
                    .ReminderMinutesBeforeStart = 60
                    .Body = ES.Cells(i, 5).Value
                    .Save
    End With
    End If
    End With
    Next i
End Sub

Sub ShowCalendar(myNamespace, myRecipient)
    Dim CalendarFolder As Outlook.MAPIFolder
    Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    CalendarFolder.Display
End Sub

Answer 1

您可以使用NameSpace.GetSharedDefaultFolder 方法获取共享日历，该方法返回代表指定用户的指定默认文件夹的Folder 对象。例如：

Sub ResolveName()
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myRecipient As Outlook.Recipient
    Dim CalendarFolder As Outlook.MAPIFolder
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
    myRecipient.Resolve
    If myRecipient.Resolved Then
        Call ShowCalendar(myNamespace, myRecipient)
    End If
End Sub

Sub ShowCalendar(myNamespace, myRecipient)
    Dim CalendarFolder As Outlook.MAPIFolder
    Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    CalendarFolder.Display
End Sub

当您获得一个共享日历文件夹时，您可以使用Items.Add 方法在该文件夹的Items 集合中创建一个新的Outlook 项目。您只需传递您需要创建的项目类型，例如olAppointmentItem。

Set myItem = mySharedCalendarFolder.Items.Add olAppointmentItem

所以，你的代码应该是这样的：

    Set wb = ThisWorkbook
    Set ES = wb.Sheets("Licences")

    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient
    Dim CalendarFolder As Outlook.MAPIFolder
    Dim olAppItem as Outlook.AppointmentItem
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
    myRecipient.Resolve

    If myRecipient.Resolved Then
        Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
        r = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 5 To r
           With Cells(i, 5)
             If .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
                Set olAppItem = CalendarFolder.Items.Add olAppointmentItem
                With olAppItem 
                    .Subject = "Test " + ES.Cells(i, 4).Value
                    .Start = ES.Cells(i, 14) + ES.Cells(i, 15).Value
                    .ReminderSet = True
                    .ReminderMinutesBeforeStart = 60
                    .Body = ES.Cells(i, 5).Value
                    .Save
                End With
             End If
         End With
       Next i

End Sub