Create Outlook appointment in specific Calendar from Excel - 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

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 = "user#test.com; user2#test.com, etc#test.com" ' 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

Answer 2

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.