Outlook macro that searches for and displays appointments that conflict with the current appointment

FindConflictingAppointments.vb

' Searches for and displays appointments that conflict with the current appointment
' If a recurring appointment, the recurrance must be saved before conflicts will be checked
' If a recurring appointment, only checks the next 50 future instances of the recurrance 
' Only checks your calendar, not the calendars of other attendees
' Based on macro from https://www.datanumen.com/blogs/quickly-find-appointments-conflicting-specific-appointment-outlook/
Sub FindConflictingAppointments()
    Dim objAppointment As AppointmentItem
    Dim dStartTime, dEndTime As Date
    Dim strFilter As String
    Dim objAppointments As Items
    Dim objFoundAppointments As Items
    Dim objItem As AppointmentItem
    Dim i As Long
    Dim conflictCount As Long
    Dim instanceConflictCount As Long
    Dim strConflicts As String
    Dim strMsg As String
    Dim currentAppointment as AppointmentItem
 
    Select Case Application.ActiveWindow.Class
           Case olExplorer
                selectionCount = Application.ActiveExplorer.Selection.Count
                If selectionCount = 0 Then
                    MsgBox "Please select an appointment", vbInformation + vbOKOnly, "Check Conflicts"
                    Exit Sub
                End If
                Set objAppointment = Application.ActiveExplorer.Selection(1)
           Case olInspector
                Set objAppointment = Application.ActiveInspector.CurrentItem
    End Select

    strMsg = objAppointment.Subject & vbCrLf & "Scheduling conflicts:" & vbCrLf & vbCrLf 

    Set objAppointments = Application.ActiveExplorer.CurrentFolder.Items()
    objAppointments.Sort "[Start]", False
    objAppointments.IncludeRecurrences = True 
    Set currentAppointment = objAppointments.Find("[Subject] = '" & objAppointment.Subject & "' and [Start] >= '" & Format(Now, "m/d/yy") & "'")
    i = 0
    conflictCount = 0
    While TypeName(currentAppointment) <> "Nothing" and i < 50
        dStartTime = currentAppointment.Start
        dEndTime = currentAppointment.End
        instanceConflictCount = 0
        strConflicts = ""

        Set allAppointments = Application.ActiveExplorer.CurrentFolder.Items
        allAppointments.Sort "[Start]", False
        allAppointments.IncludeRecurrences = True

        '1: Find all appts whose end time within the start and end time of source appt
        strFilter = "[End] > " & Chr(34) & Format(dStartTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34) & " AND [End] <= " & Chr(34) & Format(dEndTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34)
    
        Set objFoundAppointments = allAppointments.Restrict(strFilter)
    
        For Each objItem In objFoundAppointments
            If objItem.Subject <> objAppointment.Subject Then
                conflictCount = conflictCount + 1
                instanceConflictCount = instanceConflictCount + 1
                strConflicts = strConflicts & "  - " & LEFT(objItem.Subject, 50) & vbCrLf
                strConflicts = strConflicts & "    " & Format(objItem.Start, "m/d/yy h:mm AMPM") & "-" & Format(objItem.End, "m/d/yy h:mm AMPM") & vbCrLf
            End If
        Next
    
        '2: Find all appts occurring within the start and end time of source appt
        strFilter = "[Start] >= " & Chr(34) & Format(dStartTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34) & " AND [End] <= " & Chr(34) & Format(dEndTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34)
    
        Set objFoundAppointments = allAppointments.Restrict(strFilter)
    
        For Each objItem In objFoundAppointments
            If objItem.Subject <> objAppointment.Subject Then
                conflictCount = conflictCount + 1
                instanceConflictCount = instanceConflictCount + 1
                strConflicts = strConflicts & "  - " & LEFT(objItem.Subject, 50) & vbCrLf
                strConflicts = strConflicts & "    " & Format(objItem.Start, "m/d/yy h:mm AMPM") & "-" & Format(objItem.End, "m/d/yy h:mm AMPM") & vbCrLf
            End If
        Next
    
        '3: Find all appts whose start time within the start and end time of source appt
        strFilter = "[Start] >= " & Chr(34) & Format(dStartTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34) & " AND [Start] < " & Chr(34) & Format(dEndTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34)
    
        Set objFoundAppointments = allAppointments.Restrict(strFilter)
    
        For Each objItem In objFoundAppointments
            If objItem.Subject <> objAppointment.Subject Then
                conflictCount = conflictCount + 1
                instanceConflictCount = instanceConflictCount + 1
                strConflicts = strConflicts & "  - " & LEFT(objItem.Subject, 50) & vbCrLf
            End If
        Next
    
        '4: Find all appts cover the entire source appt
        strFilter = "[Start] <= " & Chr(34) & Format(dStartTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34) & " AND [End] >= " & Chr(34) & Format(dEndTime, "mm/dd/yyyy hh:mm AMPM") & Chr(34)
    
        Set objFoundAppointments = allAppointments.Restrict(strFilter)
    
        For Each objItem In objFoundAppointments
            If objItem.Subject <> objAppointment.Subject Then
                conflictCount = conflictCount + 1
                instanceConflictCount = instanceConflictCount + 1
                strConflicts = strConflicts & "  - " & LEFT(objItem.Subject, 50) & vbCrLf
            End If
        Next

        If instanceConflictCount <> 0 Then
            strMsg = strMsg & Format(currentAppointment.Start, "m/d/yy h:mm AMPM") & "-" & Format(currentAppointment.End, "h:mm AMPM") & vbCrLf
            strMsg = strMsg & strConflicts
        End If

        Set currentAppointment = objAppointments.FindNext
        i = i + 1
    Wend

    If conflictCount = 0 Then
        strMsg = strMsg & "No conflicts found"
    End If

    MsgBox strMsg, vbInformation + vbOKOnly, "Check Conflicts"


    Set objAppointment = Nothing
    Set dStartTime = Nothing
    Set objAppointments = Nothing
    Set objFoundAppointments = Nothing
    Set objItem = Nothing
    Set currentAppointment = Nothing

End Sub

Thanks for coding this Joe! The documenter in me wants to add instructions for adding and running this from within Outlook so here it goes (based on a PC environment):

1. Copy the macro code here in Joe's gist (select and push Ctrl + C).

2. Within Outlook, press Alt + F11 to get to the Visual Basic Editor

3. In the Visual Basic Editor, click the Insert tab and select Module. Then find your new module (likely Module1) in the explorer window on the left and double-click it.

4. A module code window will open on the right. Click into a blank space and paste your copied macro code (Ctrl + V).

5. Press Ctrl + S to save.

6. Close the Visual Basic Editor (click the X in the top right)
   

7. Now add a button on your Quick Access Toolbar by going to File tab > Options > Quick Access Toolbar. Under Choose commands from, select Macros in the dropdown list. Select Project1.FindConflictingAppointments and click Add>>.

8. If you want to modify the name or icon, select the added item under Customize Quick Access Toolbar and then click the Modify button. When your finished be sure to click OK in the Outlook Options window.

9. To run the macro, select an appointment in your calendar and then click your new macro button.