Displaying open time slots for Outlook calendar in Excel

Question

I have created a code that displays open time slots for people who have shared their calendars with me. Inputting a date in a cell displays all open time slots in a list box in the format of Employee, start time, end time.

The code only works if it is the 15th of the month and later. For the first 15 days the list box shows 9 am to 5 pm and doesn't pull the open slots.

Option Explicit

Dim objOL As New Outlook.Application    ' Outlook
Dim objNS As Namespace                  ' Namespace
Dim OLFldr As Outlook.MAPIFolder        ' Calendar folder
Dim OLAppt As Object                    ' Single appointment
Dim OLRecip As Outlook.Recipient        ' Outlook user name
Dim OLAppts As Outlook.Items            ' Appointment collection
Dim strDay As String                    ' Day for appointment
Dim strList As String                   ' List of all available timeslots
Dim dtmNext As Date                     ' Next available time
Dim intDuration As Integer              ' Duration of free timeslot
Dim i As Integer                        ' Counter

Const C_Procedure = "FindFreeTime"      ' Procedure name
Const C_dtmFirstAppt = #9:00:00 AM#     ' First appointment time
Const C_dtmLastAppt = #5:00:00 PM#      ' Last appointment time
Const C_intDefaultAppt = 30             ' Default appointment duration

On Error GoTo ErrHandler

    ' list box column headings
strList = "Employee;Start Time;End Time;"

    ' get full span of selected day
strDay = "[Start] >= '" & dtmAppt & "' and " & _
         "[Start] < '" & dtmAppt & " 11:59 pm'"

    ' loop through shared Calendar for all Employees in array
Set objNS = objOL.GetNamespace("MAPI")

For i = 0 To UBound(strEmp)
    On Error GoTo ErrHandler
    Set OLRecip = objNS.CreateRecipient(strEmp(i))

    On Error Resume Next
    Set OLFldr = objNS.GetSharedDefaultFolder(OLRecip, olFolderCalendar)

        ' calendar not shared
    If Err.Number <> 0 Then
        strList = strList & strEmp(i) & _
            ";Calendar not shared;Calendar not shared;"

        GoTo NextEmp
    End If

    On Error GoTo ErrHandler
    Set OLAppts = OLFldr.Items

    dtmNext = C_dtmFirstAppt

        ' Sort the collection (required by IncludeRecurrences)
    OLAppts.Sort "[Start]"

        ' Make sure recurring appointments are included
    OLAppts.IncludeRecurrences = True

        ' Filter the collection to include only the day's appointments
    Set OLAppts = OLAppts.Restrict(strDay)

        ' Sort it again to put recurring appointments in correct order
    OLAppts.Sort "[Start]"

    With OLAppts
            ' capture subject, start time and duration of each item
        Set OLAppt = .GetFirst

        Do While TypeName(OLAppt) <> "Nothing"
                ' find first free timeslot
            Select Case DateValue(dtmAppt)
                Case DateValue(Format(OLAppt.Start, "dd/mm/yyyy"))
                    If Format(dtmNext, "Hh:Nn") < _
                        Format(OLAppt.Start, "Hh:Nn") Then

                            ' find gap before next appointment starts
                        If Format(OLAppt.Start, "Hh:Nn") < _
                                Format(C_dtmLastAppt, "Hh:Nn") Then
                            intDuration = DateDiff("n", dtmNext, _
                                            Format(OLAppt.Start, "Hh:Nn"))
                        Else
                            intDuration = DateDiff("n", dtmNext, _
                                            Format(C_dtmLastAppt, "Hh:Nn"))
                        End If

                            ' can we fit an appointment into the gap?
                        If intDuration >= C_intDefaultAppt Then
                            strList = strList & strEmp(i) & _
                                ";" & Format(dtmNext, "Hh:Nn ampm") & _
                                ";" & Format(DateAdd("n", intDuration, _
                                        dtmNext), "Hh:Nn ampm") & ";"
                        End If
                    End If

                        ' find first available time after appointment
                    dtmNext = DateAdd("n", OLAppt.Duration + intDuration, _
                                    dtmNext)

                        ' don't go beyond last possible appointment time
                    If dtmNext > C_dtmLastAppt Then
                        Exit Do
                    End If
            End Select

            intDuration = 0

            Set OLAppt = .GetNext
        Loop
    End With

        ' capture remainder of day
    intDuration = DateDiff("n", dtmNext, Format(C_dtmLastAppt, "Hh:Nn"))

    If intDuration >= C_intDefaultAppt Then
        strList = strList & strEmp(i) & _
            ";" & Format(dtmNext, "Hh:Nn ampm") & _
            ";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & _
            ";"
    End If

NextEmp:
    ' add note for unavailable Employee
    If InStr(1, strList, strEmp(i)) = 0 Then
        strList = strList & strEmp(i) & _
            ";Unavailable this day;Unavailable this day;"
    End If
Next i

FindFreeTime = strList

ExitHere:
    On Error Resume Next
    Set OLAppt = Nothing
    Set OLAppts = Nothing
    Set objNS = Nothing
    Set objOL = Nothing
    Exit Function

ErrHandler:
    MsgBox Err.Number & ": " & C_Procedure & vbCrLf & Err.Description
    Resume ExitHere
End Function

Answer 1

It is always the date format

        ' Will likely be wrong from the 1st to the 12th day
        Debug.Print " DateValue(Format(OLAppt.Start, dd/mm/yyyy)): " & DateValue(Format(OLAppt.start, "dd/mm/yyyy"))

        ' Figure out the format that works for you
        Debug.Print " DateValue(Format(OLAppt.Start, yyyy-mm-dd)): " & DateValue(Format(OLAppt.start, "yyyy-mm-dd"))

        Select Case DateValue(dtmAppt)

            'Case DateValue(Format(OLAppt.start, "dd/mm/yyyy"))
            Case DateValue(Format(OLAppt.start, "yyyy-mm-dd"))