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

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

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 .

Answer 2

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 3

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