Saving appointments to a shared Outlook calendar from Excel

Question

I have a script which adds an appointment to a shared outlook calendar. The script below works on the calendar's host computer but not from other pc's. The code is:

Sub OC1SOAK()
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Dim OutTaskOC11 As Outlook.AppointmentItem
Dim OutTaskOC12 As Outlook.AppointmentItem
Dim OutTaskOC115 As Outlook.AppointmentItem
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("*folderidhere*")
With oFolder
    Set OutTaskOC11 = oFolder.Items.ADD(olAppointmentItem)
    Set OutTaskOC12 = oFolder.Items.ADD(olAppointmentItem)
    Set OutTaskOC115 = oFolder.Items.ADD(olAppointmentItem)
    With OutTaskOC11
        .Subject = TR.Text + "   " + Fuel1.Text + "   " + "Vapor" + "   " + "Start"
        .Start = startdate.Text
        .End = startdate.Text
    End With
    With OutTaskOC12
        .Subject = TR.Text + "   " + Fuel1.Text + "   " + "Submerged"
        .Start = Format(DateValue(startdate.Text) + Val("3"), "mm/dd/yyyy")
        .End = Format(DateValue(startdate.Text) + Val("3"), "mm/dd/yyyy")
    End With
        With OutTaskOC115
        .Subject = TR.Text + "   " + "Finished"
        .Start = Format(DateValue(startdate.Text) + Val("6"), "mm/dd/yyyy")
        .End = Format(DateValue(startdate.Text) + Val("6"), "mm/dd/yyyy")
    End With
    OutTaskOC11.SAVE
    OutTaskOC12.SAVE
    OutTaskOC115.SAVE
End With
End Sub

The error I get is,

Run-time error '-2147220991 (80040201)': The operation failed. The messaging interfaces have returned an unknown error. If the problem persists, restart outlook.

Anyone have any ideas why? I've checked calendar share permissions. I originally thought it was due using Createitems/move so I went with items.add instead.

Any help is appreciated.

Answer 1

I haven't tested this on other PCs, but the code below works fine for me.

Private Sub Add_Appointments_To_Outlook_Calendar()

    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oAppt As AppointmentItem
    Dim Remind_Time As Double

    i = 2
    Subj = ThisWorkbook.Sheets(1).Cells(i, 1)

    'Loop through entire list of Reminders to be added
    While Subj <> ""
        Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)

        oAppt.Subject = Subj
        oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
        oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
        Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
        oAppt.ReminderMinutesBeforeStart = Remind_Time
        oAppt.AllDayEvent = True
        oAppt.Save

        i = i + 1
        Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
    Wend
    MsgBox "Reminder(s) Added To Outlook Calendar"

End Sub

' https://www.slipstick.com/developer/create-appointments-spreadsheet-data/

' https://blogs.msdn.microsoft.com/brunoterkaly/2014/07/24/scheduling-appointments-in-outlook-from-excel/