Loading appointments to a non-default Outlook calendar from Excel

Question

I have a project to put employees leave schedules into a shared or global calendar.

The appointments save to my default calendar.

I have tried a few different approaches. This is the current approach:

Sub Create_Outlook_2()
' Create the Outlook session

Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Dim myApt As AppointmentItem

Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000").Items.Add(olAppointmentItem)

With oFolder
'    Set myOutlook = CreateObject("Outlook.Application")
'    ' Set data collection to take from "Leave Table" sheet
    Dim wsSrc As Worksheet
    Set wsSrc = Sheets("Leave Table")
    ' Start looping at row 3 (first two rows are for readability)
    r = 3
    ' Do/while set condition
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""
        ' Create event item
        Set myApt = oApp.CreateItem(1)
        ' Set the event properties
        ' Set Subject line of event
        With myApt
            .Subject = "Time Off " & wsSrc.Cells(r, 1).Value & " " & wsSrc.Cells(r, 2).Value
           ' Set start time
            .Start = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 8).Value
           ' Set end time
            .End = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 9).Value
           ' Turn reminders off
            .ReminderSet = False
           ' Set busy status to free
            .BusyStatus = 0
           ' Have the body of the event read as the decription from the leave form in Viewpoint
            .Body = wsSrc.Cells(r, 4).Value
           ' Save event in owners calendar
            .Save

        End With
       ' Move to next row
        r = r + 1
       ' Repeat do/while loop until condition is no longer valid
    Loop

End With
End Sub

Answer 1

I figured it out:

Sub Create_Outlook_2()

    Dim oApp As Object
    Dim oNameSpace As Namespace
    Dim oFolder As Object
    Dim wsSrc As Worksheet
    Set wsSrc = Sheets("Leave Table")
    ' Start looping at row 3 (first two rows are for readability)
    r = 3
    ' Do/while set condition
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""

        ' Create the Outlook session
        Set oApp = New Outlook.Application
        ' Set the namespace
        Set oNameSpace = oApp.GetNamespace("MAPI")
        ' Set the folder the appointment will be created in.
        Set oFolder = oNameSpace.GetFolderFromID("Folder ID Number").Items.Add(olAppointmentItem)

        ' Set with block for the appointment configuration loop
        With oFolder
           ' Set Subject line of event
            .Subject = wsSrc.Cells(r, 1).Value & " " & wsSrc.Cells(r, 2).Value
           ' Set start time
            .Start = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 8).Value
           ' Set end time
            .End = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 9).Value
           ' Turn reminders off
            .ReminderSet = False
           ' Set busy status to free
            .BusyStatus = 0
           ' Have the body of the event read as the decription from the leave form in Viewpoint
            .Body = wsSrc.Cells(r, 4).Value
           ' Save event in owners calendar
            .Save
           ' End with block
        End With
       ' Move to next row
        r = r + 1
       ' Repeat do/while loop until condition is no longer valid
    Loop

End Sub

To get Folder ID #:

With the calendar you want to create appointments in selected (open it in a new window for good measure), press F11 to bring up Outlook macros and run the following code under "ThisOutlookSession":

Private Sub GetOutlookFolderID()
     'Determines the Folder ID of Folder
    Dim olfolder As Outlook.MAPIFolder
    Dim olapp As Outlook.Application
    Set olapp = CreateObject("Outlook.Application")
    Set olfolder = olapp.GetNamespace("MAPI").PickFolder
    olfolder.Display
    MsgBox (olfolder.EntryID)
    Set olfolder = Nothing
    Set olapp = Nothing
End Sub

Sample spreadsheet - with fake names: