Create Outlook appointment in specific Calendar from Excel

Question

I am trying to create three Outlook appointments in a specific (shared) calendar.

The events will be all-day events. I want the dates for the current row to be added to the calendar. All three dates will be in the same row on the spreadsheet.

The code creates the appointment but the for loop is not working. The only event that is created is the last date.

Sub Makeapt()
Set myOutlook = CreateObject("Outlook.Application")

Set myApt = myOutlook.createitem(1)
Dim i As Integer    
For i = 3 To 5
    myApt.Subject = Cells(ActiveCell.Row, 1).Value
    myApt.Start = Cells(ActiveCell.Row, i).Value
    myApt.Save
Next i

End Sub

I solved the problem. Appt still goes to the default calendar, but that is actually preferable.

Sub Makeapt()

Dim warning
warning = MsgBox("You are about to create Outlook appointments for subject #" & Cells(ActiveCell.Row, 3) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub

Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 3)
Dim i As Integer

For i = 7 To 9
    Set myApt = myOutlook.createitem(1)
    myApt.Subject = "Subject #" & ID
    myApt.Start = Cells(ActiveCell.Row, i).Value
    myApt.Save
Next i

End Sub

Answer 1

If you want a shared calendar, create a recipient object using Application.CreateRecipient, open the shared calendar using Application.Session.GetSharedDefaultFolder, create an appointment using MAPIFolder.Items.Add.

Answer 2

Dmitry nailed it for how to create an appointment/meeting in a shared calendar from Excel. His post was a big help to me as it seems there are not any very good answers to how to create an appointment on a shared calendar. I looked all over numerous forums to get answers and came up with very little. Based on his answer, I was able to get it working. Below is an example script I put together. This is a somewhat stripped-down version of what I am using for my needs, but I did test this example and it works. Just make sure the Outlook library is selected in the Excel VBA editor's Tools->References menu item.

Sub SendInvitationAsUser()

Rcpts = "[email protected]; [email protected], [email protected]" ' These can be in other formats that Outlook understands like display name.
Subject = "Meeting sent from shared calendar"

' Creates Outlook instance
Set OutApp = CreateObject("Outlook.Application")

Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim objfolder As Outlook.Folder

Set myNamespace = OutApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Smith, John Q") 'The invite will come from this user's mailbox
myRecipient.Resolve
If myRecipient.Resolved Then
   Set objfolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) 'Sets folder where appt will be created
Else
    ok = MsgBox("Unable to resolve the name of the sender.", vbCritical, "Error")
    Exit Sub
End If

Set OutlookAppt = objfolder.Items.Add(olAppointmentItem) 'Creates appointment in shared calendar

' Edit Outlook appointment, convert to meeting invitation by adding recipients.
With OutlookAppt
    .MeetingStatus = olMeeting
    .Subject = Subject
    .Start = #1/1/2018 8:00:00 AM#
    .End = #1/1/2018 9:00:00 AM#
    .Location = "Conference Room 1"
    .RequiredAttendees = Rcpts
End With

'Use Word to do fancy formatting of body text. Example below is basic but a lot of formatting via VBA is possible.
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
Set DocSelection = WordApp.Selection

WordApp.Visible = True 
WordDoc.Activate ' You want to see the window, right?

DocSelection.Font.Name = "Arial" ' Everything is Arial.
DocSelection.Font.Size = "10" ' Everything is size 10.
DocSelection.ParagraphFormat.SpaceAfter = "0" ' No line spacing.
DocSelection.ParagraphFormat.SpaceBefore = "0" ' No line spacing.

DocSelection.TypeText ("Please plan to attend my meeting.")

WordDoc.Content.Copy
OutlookAppt.Display
Set TargetApptDoc = OutlookAppt.GetInspector.WordEditor
TargetApptDoc.Range(0, 0).Paste

WordDoc.Close savechanges:=False
WordApp.Quit

End Sub