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 (1198 downloads )