Yet again, I was trying to help someone out in an Access forum who was trying to write code to add an appointment to their Outlook Calendar. So I dug up a function I had developed for a project I had worked on many years ago and thought it might help other.

'---------------------------------------------------------------------------------------
' Procedure : CreateAppointment
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Create Appointments in Outlook
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding  -> None required
'             Early Binding -> Microsoft Outlook XX.X Object 
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sSubject              : Subject line
' sBody                 : Body text
' sLocation             : Location of appointment
' dtStart               : Start Date/Time
' dtEnd                 : End Date/Time
' bAllDayEvent          : Is the appointment a full day event True/False
' bDisplayToUser        : Display the newly created appointment item to the end-user True/False
' sCategories           : Name of the Category(ies) to assign to the appointment
' lReminderMinsBefore   : Number of minute prior to the appointment to prompt a reminder
' sOrganizers           : Name/Email of the meeting orgainizer
' sRequiredAttendees    : Name/Email of the required meeting attendees
' sOptionalAttendees    : Name/Email of the optional meeting attendees
' sResources            : Name/Email of the meeting resources
'
' Usage:
' ~~~~~~
' Call CreateAppointment("Project Review", "Initial Delivery Review Metting with the client", _
                         "Main Board room", #01/13/2017 12:00#, #01/13/2017 14:00#, False)
' Call CreateAppointment("Project Review", "Initial Delivery Review Metting with the client", _
                         "Main Board room", #01/13/2017 12:00#, #01/13/2017 14:00#, False, True)
' Call CreateAppointment("Project Review", "Initial Delivery Review Metting with the client", _
                         "Main Board room", #9/6/2018 12:00:00 PM#, #9/6/2018 2:00:00 PM#, False, True, _
                         "Green Category")
' Call CreateAppointment("Project Review", "Initial Delivery Review Metting with the client", _
                         "Main Board room", #09/06/2018 12:00#, #09/06/2018 14:00#, False, True, _
                         "Green Category, Red Category")
' Call CreateAppointment("Project Review", "Initial Delivery Review Metting with the client", _
                         "Main Board room", #09/06/2018 12:00#, #09/06/2018 14:00#, False, True, _
                         "Green Category, Red Category", 60, "someone@somehwere.com", _
                         "someonelese@somewhere.com;anotherperson@somewhere.com", _
                         "yetanotherperson@somedomain.com")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2011-11-17              Initial Release
' 2         2017-01-16              Added GetObject(), instead of just CreateObject()
'                                   Added sLocation
'                                   Added bDisplayToUser
' 3         2017-02-21              Added Conditional Compiling Directives (CCDs) for
'                                       switching between Early and Late Binding
' 4         2018-09-06              Added sCategories
'                                       updated copyright
' 5         2024-05-08              Added meeting reminder
'                                   Added meeting attendees & resources
' 6         2025-01-31              Fixed #Const EarlyBind declaration for Late Binding
'                                      per Jesse Fuller's comment
'---------------------------------------------------------------------------------------
Public Function CreateAppointment(sSubject As String, _
                                  sBody As String, _
                                  sLocation As String, _
                                  dtStart As Date, _
                                  dtEnd As Date, _
                                  bAllDayEvent As Boolean, _
                                  Optional bDisplayToUser As Boolean = False, _
                                  Optional sCategories As String, _
                                  Optional lReminderMinsBefore As Long = 0, _
                                  Optional sOrganizers As String, _
                                  Optional sRequiredAttendees As String, _
                                  Optional sOptionalAttendees As String, _
                                  Optional sResources As String) As Boolean
    On Error GoTo Error_Handler
    #Const EarlyBind = False    'Use Late Binding, No Reference Library Required
    '    #Const EarlyBind = True    'Use Early Binding, Requires Reference Library
    #If EarlyBind = True Then
        Dim OApp              As Outlook.Application
        Dim OAppt             As Outlook.AppointmentItem
        Dim oRecipient        As Outlook.Recipient
    #Else
        Dim OApp              As Object
        Dim OAppt             As Object
        Dim oRecipient        As Object
        Const olAppointmentItem = 1
        Const olOrganizer = 0
        Const olRequired = 1
        Const olOptional = 2
        Const olResource = 3
    #End If
    Dim aAttendees()          As String
    Dim iCounter              As Long
    Dim bAppOpened            As Boolean

    'Initiate our instance of the oApp object so we can interact with Outlook
    On Error Resume Next
    Set OApp = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If Err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        Err.Clear
        Set OApp = CreateObject("Outlook.Application")
        bAppOpened = False    'Outlook was not already running, we had to start it
    Else
        bAppOpened = True    'Outlook was already running
    End If
    On Error GoTo Error_Handler

    'Start creating our Appointment
    Set OAppt = OApp.CreateItem(olAppointmentItem)
    With OAppt
        '        .To = ""
        .Start = dtStart
        .End = dtEnd
        .AllDayEvent = bAllDayEvent
        .Subject = sSubject
        .Body = sBody
        '.RTFBody = sBody 'If using formatted text
        .Location = sLocation
        If IsMissing(sCategories) = False Then .Categories = sCategories
        '        .ShowCategoriesDialog
        '        MsgBox .Categories
        If bDisplayToUser = True Then .Display

        If lReminderMinsBefore > 0 Then
            .ReminderSet = True
            .ReminderMinutesBeforeStart = lReminderMinsBefore
        Else
            .ReminderSet = False
        End If


        If sOrganizers <> "" Then
            If Right(sOrganizers, 1) = ";" Then sOrganizers = Left(sOrganizers, Len(sOrganizers) - 1)
            aAttendees = Split(sOrganizers, ";")
            For iCounter = 0 To UBound(aAttendees)
                Set oRecipient = .Recipients.Add(aAttendees(iCounter))
                oRecipient.Type = olOrganizer
                DoEvents
            Next iCounter
        End If
        If sRequiredAttendees <> "" Then
            If Right(sRequiredAttendees, 1) = ";" Then sRequiredAttendees = Left(sRequiredAttendees, Len(sRequiredAttendees) - 1)
            aAttendees = Split(sRequiredAttendees, ";")
            For iCounter = 0 To UBound(aAttendees)
                Set oRecipient = .Recipients.Add(aAttendees(iCounter))
                oRecipient.Type = olRequired
                DoEvents
            Next iCounter
        End If
        If sOptionalAttendees <> "" Then
            If Right(sOptionalAttendees, 1) = ";" Then sOptionalAttendees = Left(sOptionalAttendees, Len(sOptionalAttendees) - 1)
            aAttendees = Split(sOptionalAttendees, ";")
            For iCounter = 0 To UBound(aAttendees)
                Set oRecipient = .Recipients.Add(aAttendees(iCounter))
                oRecipient.Type = olOptional
                DoEvents
            Next iCounter
        End If
        If sResources <> "" Then
            If Right(sResources, 1) = ";" Then sResources = Left(sResources, Len(sResources) - 1)
            aAttendees = Split(sResources, ";")
            For iCounter = 0 To UBound(aAttendees)
                Set oRecipient = .Recipients.Add(aAttendees(iCounter))
                oRecipient.Type = olResource
                DoEvents
            Next iCounter
        End If

        .Save
        '        .Send
    End With

    CreateAppointment = True

    'If our code started Outlook, we should close it now that we're done
    If bAppOpened = False Then
        OApp.Quit    'There seems to be a delay in this action taking place, but does eventually take place
    End If

Error_Handler_Exit:
    On Error Resume Next
    If Not OAppt Is Nothing Then Set OAppt = Nothing
    If Not OApp Is Nothing Then Set OApp = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: CreateAppointment" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl), _
           vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

The beauty of the above is that by default (yes, you can change it if you wish) it uses Late Binding and thus you do not need to add any reference libraries to your VBA project. Simply drop this into a standard module and it works. As always, don’t forget about my work around for situations where CreateObject(“Outlook.Application”) does not work: CreateObject(“Outlook.Application”) Does Not Work, Now What?.

Other Resources

• AppointmentItem object (Outlook)