How to make a single, non-duplicating, Outlook Calendar Entry? - excel

Question

I'm trying to run some VBA code in Excel. When the file is saved I'd like to add a calendar entry.
I have the basics working using the following code:
Private Sub CreateAppointment()
Set olOutlook = CreateObject("Outlook.Application")
Set Namespace = olOutlook.GetNamespace("MAPI")
Set oloFolder = Namespace.GetDefaultFolder(9)
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To LastRow
Description = Cells(i, 6).Value
StartDate = Cells(i, 5).Value
Set Appointment = oloFolder.Items.Add
With Appointment
.Start = StartDate
.Subject = Description
.Save
End With
Next i
End Sub
Each time the sheet is saved it creates a duplicate entry.
How do I adjust this code so only one instance is added as a calendar entry in Outlook?

Answer 1

Indicate in the Excel document that the row was processed.
Update a cell in an unused column the row.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub CreateAppointment_VerifyCellInRow()
Dim oOutlook As Object
Dim oNamespace As Object
Dim oFolder As Object
Dim oAppointment As Object
Dim LastRow As Long
Dim i As Long
Dim startDate 'As Date
Dim Description As String
Dim createIndicator As String
Set oOutlook = CreateObject("Outlook.Application")
Set oNamespace = oOutlook.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(9)
createIndicator = "Added"
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To LastRow
If Cells(i, 7).Value <> createIndicator Then
startDate = Cells(i, 5).Value
'StartDate = Format(Date + 1, "ddddd ") & "03:00 PM"
Debug.Print startDate
Description = Cells(i, 6).Value
'Description = "Test"
Debug.Print Description
Set oAppointment = oFolder.Items.Add
With oAppointment
.Start = startDate
.Subject = Description
.Save
Cells(i, 7).Value = createIndicator
End With
End If
Next i
End Sub

Answer 2

If creating appointments where the source document cannot be updated to indicate that the appointment was processed.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub CreateAppointment_SearchCalendar()
Dim oOutlook As Object
Dim oNamespace As Object
Dim oFolder As Object
Dim oAppt As Object
Dim Description As String
Dim startDate As Date
Dim LastRow As Long
Dim i As Long
Set oOutlook = CreateObject("Outlook.Application")
Set oNamespace = oOutlook.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(9)
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To LastRow
startDate = Cells(i, 5).Value
'startDate = Format(Date + 1, "ddddd ") & "03:00 PM"
Debug.Print startDate
Description = Cells(i, 6).Value
'Description = "Test"
Debug.Print Description
If Calendar_ApptExists(oFolder, startDate, Description) = False Then
Set oAppt = oFolder.Items.Add
With oAppt
.Start = startDate
.Subject = Description
.Save
Debug.Print "Appointment created."
End With
Else
Debug.Print "Existing appointment at " & startDate & " with subject: " & Description
End If
Next
End Sub
Function Calendar_ApptExists(oCalendar As Object, appt_Start As Date, appt_subject As String) As Boolean
Dim oCalendarItems As Object
Dim oAppt As Object
Dim strFilter As String
Dim strFilter2 As String
Dim oCalendarItemsDate As Object
Dim oCalendarItemsDateSubject As Object
Set oCalendarItems = oCalendar.Items
' Items in calendar
Debug.Print "Items in Calendar: " & oCalendarItems.Count
' Appointments with appt_Start
strFilter = "[Start] = " & Chr(34) & Format(appt_Start, "ddddd hhmm AM/PM") & Chr(34)
Debug.Print " " & strFilter
Set oCalendarItemsDate = oCalendarItems.Restrict(strFilter)
Debug.Print " Appointments starting at " & appt_Start & ": " & oCalendarItemsDate.Count
strFilter2 = strFilter & " and " & "[Subject] = '" & appt_subject & "'"
Debug.Print " " & strFilter2
Set oCalendarItemsDateSubject = oCalendarItems.Restrict(strFilter2)
Debug.Print " strFilter2 appointments: " & oCalendarItemsDateSubject.Count
If oCalendarItemsDate.Count > 0 Then
Debug.Print " Existing appointment at same time."
If oCalendarItemsDateSubject.Count > 0 Then
Debug.Print " Existing appointment with same time and subject."
Calendar_ApptExists = True
End If
End If
End Function

Answer 3

After calling Save, read the EntryID property and save it. Next time (if it is set), you can call Namespace.GetItemFromID instead of Folder.Items.Add.