Excel VBA – Create and update Outlook Calendar Items

With the Sub UpdateAppointment you can create and update Outlook meetings or appointments. All items must have a unique index to filter on. The sub filters on BillingInformation, a field I rarely use for other purposes.

Appointments

The appointments are created in your personal calendar. If you want to put stuff in others calendar, you can create a meeting, set a specific category with a dull color that you can ignore. Changes in Outlook that makes it impossible to update the item as an appointment or meeting, will be re-created.

Updates in Outlook

You can update the items in Outlook and use ReadAppointment to read info back to Excel.

Meetings

Include an e-mail address, and the recipient will receive a meeting request.

Download

At the bottom of this article you can download the workbook.

References needed in the VBAProject

To run the code, you need the Microsoft Outlook xx Object library.

Sub ReadAppointment

The ReadAppointment sub reads the Item with the unique index you provide. This way you can organize the items in Outlook and read the date, starttime and endtime back to your workbook.

Usage sample

The Demo sub calls the Testappointment sub which creates two calendar Items on 13. september 2021, and updates the start time to a random time in each loop.

Sub Demo()
    Randomize
 
    While 1
    
        TestAppointment "UniqueId00"
        TestAppointment "UniqueId01"
 
        Debug.Assert 1 > 1
 
    Wend
End Sub

Sub TestAppointment(UniqueId)
    
    Dim AppointmentData As Variant
    AppointmentData = ReadAppointment(UniqueId)

    Dim x As Long
    Dim Label As String
    Dim Msg As String
    
    If Not IsEmpty(AppointmentData) Then
     
        For x = 1 To UBound(AppointmentData)
        
            Select Case x
         
                Case 1
                    Label = "Date"
         
                Case 2
                    Label = "From"
         
                Case 3
                    Label = "To"
        
            End Select
        
            Msg = Msg & Label & ":  " & AppointmentData(x) & ", "
        
        Next x

        If Msg <> "" Then
            'MsgBox Msg
            Debug.Print Msg
        End If
    
    End If
    
    Dim Subject As String
    Dim Starttime As String
    Dim StopTime As String
    Dim BodyText As String
    Dim Email As String
    Dim Category As String
    
    Dim RandomStartHour As String
    RandomStartHour = Start

    Subject = "This is my Subject"
    Starttime = "2021.09.13 " & RandomStartHour & ":00"
    StopTime = "2021.09.13 " & RandomStartHour & ":59"
    BodyText = "BodyText"
    'Email = "demouser@xgmail.com"
    Category = "Demo" & Right(UniqueId, 2)
    
    UpdateAppointment UniqueId, Subject, Starttime, StopTime, BodyText, Email, Category

End Sub

Function Start() As String

 Start = Format(Rnd(8) * 10 + 5, "00")

End Function

Module ModOutlook code

Option Explicit

 
Sub UpdateAppointment(ByVal AppointId As String, Subj As String, Starttime, EndTime, Body As String, Email As String, Category As String, Optional DeleteAppoint As Long)
 
    Dim oApp As Outlook.Application
    Dim oNS As Outlook.Namespace
    Dim oFLDR As Outlook.MAPIFolder
    Dim Appoint As Outlook.AppointmentItem
    Dim oObject As Object
    Dim sMessage As String
    
    Dim Found As Boolean
    
    Found = False
    
    On Error Resume Next
    Set oApp = GetObject("Outlook.Application")
 
    If Err <> 0 Then
        Set oApp = CreateObject("Outlook.Application")
    End If
    
    On Error GoTo Err_Handler
 
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFLDR = oNS.GetDefaultFolder(olFolderCalendar)
    
    Dim Filter As String
    
    Filter = "[BillingInformation] = '" & AppointId & "'"

    Dim oFilteredItems
    Set oFilteredItems = oFLDR.Items.Restrict(Filter)

    Found = False
    Dim UpdateAppoint As Outlook.AppointmentItem
    
    If oFilteredItems.Count > 0 Then
    
        'Should only be one if Index is unique
        Set Appoint = oFilteredItems(1)
        Set UpdateAppoint = Appoint
        Found = True
    
    End If
    
    'If not found, create new
    If Found = False And DeleteAppoint = 0 Then
        Set UpdateAppoint = oApp.CreateItem(olAppointmentItem)
    End If
    
    'Update or create info
    If DeleteAppoint = 0 Then
    
        If LCase(Environ("UserName")) = "ketil" Then
            On Error GoTo 0
        End If
    
        'If we fail to update existing Item, we re-create it
        If SetAppoint(UpdateAppoint, Subj, Starttime, EndTime, Category, Body, AppointId) Is Nothing Then
     
            Set UpdateAppoint = oApp.CreateItem(olAppointmentItem)
            UpdateAppoint = SetAppoint(UpdateAppoint, Subj, Starttime, EndTime, Category, Body, AppointId)
        
        End If
        
        'Appointment or meeting
        With UpdateAppoint
                
            If Email <> "" Then
                
                .MeetingStatus = olMeeting
                .Recipients.Add (Email)
                .Send
                
            Else
                
                .Save
                
            End If
        
        End With
    
    End If
 
    If DeleteAppoint Then
        
        If Found = True Then
            UpdateAppoint.Delete
        End If
         
    End If
 
 
    Set oApp = Nothing
    Set oNS = Nothing
    Set Appoint = Nothing
    Set oFLDR = Nothing
    Set oObject = Nothing
 
    Exit Sub
 
Err_Handler:
    MsgBox Err.Number & " " & Err.Description
 
End Sub

Function SetAppoint(Item As Outlook.AppointmentItem, Subj As String, Starttime, EndTime, Category As String, Body As String, AppointId As String) As Outlook.AppointmentItem

    On Error GoTo Err_Handler

    With Item

        .Subject = Subj
        .Start = Starttime
        .End = EndTime
        .AllDayEvent = False
        .Categories = Category
        .Body = Body
        .BillingInformation = AppointId

    End With

    Set SetAppoint = Item

    Exit Function

Err_Handler:
    Set SetAppoint = Nothing

End Function

Function ReadAppointment(ByVal AppointId As String) As Variant
 
    Dim oApp As Outlook.Application
    Dim oNS As Outlook.Namespace
    Dim oFLDR As Outlook.MAPIFolder
    Dim Appoint As Outlook.AppointmentItem
    Dim oObject As Object
 
    Dim strErrorMessage As String
    
    Dim Found As Boolean
    
    Found = False
    
    On Error Resume Next
    Set oApp = GetObject("Outlook.Application")
 
    If Err <> 0 Then
        Set oApp = CreateObject("Outlook.Application")
    End If
    
    On Error GoTo Err_Handler
 
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFLDR = oNS.GetDefaultFolder(olFolderCalendar)
    
    Dim Filter As String
    
    Filter = "[BillingInformation] = '" & AppointId & "'"

    Dim oFilteredItems 'As Outlook.MAPIFolder
    Set oFilteredItems = oFLDR.Items.Restrict(Filter)

    Found = False
    Dim UpdateAppoint As Outlook.AppointmentItem
    
    If oFilteredItems.Count > 0 Then
    
        Dim x As Long
        For x = 1 To oFilteredItems.Count
 
            Set Appoint = oFilteredItems(x)
            Set UpdateAppoint = Appoint
            Found = True
    
        Next x
    
    End If
    
    'If not found, exit
    If Found = False Then
        Exit Function
    End If
    
    'Update or create info
    
    Dim Value(3) As String
    Dim Streng As String
    Dim a As Long
    
    With UpdateAppoint
    
        Streng = .Start
     
        a = InStr(1, Streng, " ") - 1
        
        If a > -1 Then
        
            Value(1) = Left(Streng, a)
     
            Value(2) = Trim(Mid(Streng, a + 2, 5))
     
            Streng = .End
            Value(3) = Trim(Mid(Streng, a + 2, 5))
        
            ReadAppointment = Value
           
        End If
           
    End With
    
    'End If
 
    Set oApp = Nothing
    Set oNS = Nothing
    Set Appoint = Nothing
    Set oFLDR = Nothing
    Set oObject = Nothing
 
    Exit Function
 
Err_Handler:
    strErrorMessage = Err.Number & " " & Err.Description
 
End Function

Download the Excel Workbook: Excel VBA: Create and Update Outlook Calendar Items (1217 downloads )