Create Outlook appointment in shared calendar - excel

Question

I have the following code set up to create appointments in Outlook from data on my Excel spreadsheet. What I would like to do id make the appointment in a shared calendar rather than my own default one.
The calendar I want to add it to is the DTS Streetworks one as shown here - https://ibb.co/tKXKSPX, but I have no idea how to go about it.
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
UPDATE:
Latest code below, still goes to default calendar.
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

You can get the shared calendar by using the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. For example:
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
When you get a shared calendar folder you may use the Items.Add method which creates a new Outlook item in the Items collection for the folder. You just need to pass an item type you need to create, for example, olAppointmentItem.
Set myItem = mySharedCalendarFolder.Items.Add olAppointmentItem
So, your code should look like this:
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