VBA in Excel to find free appointment in Outlook and display in an email

[RockEd]

Hello,
I'm using my excel sheet to find an appointment within the next 2 weeks and send an email (I eventually want to find the next 2 appointments that aren't on the same day however small steps first!).

I've written the following code but cannot see where I'm going wrong as it cannot find any appointments within the next 2 weeks. Is anyone able to help?

Many thanks

Option Explicit

Sub SendAvailableTimeSlots()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olRestrictItems As Outlook.Items
    Dim olItem As Outlook.AppointmentItem
    Dim olEmail As Outlook.MailItem
    Dim olStartTime As Date
    Dim olEndTime As Date
    Dim olDuration As String
    Dim olMaxDuration As String
    Dim olFilter As String
    Dim i As Long
    Dim j As Long
    Dim strBody As String
    Dim olMaxDurationStr As String

    ' Define working hours and maximum duration
olStartTime = TimeValue("9:00:00 AM")
olEndTime = TimeValue("5:00:00 PM")

    olDuration = "01:00:00"
    olMaxDuration = TimeValue(olDuration) ' Convert olDuration to a number
    olMaxDurationStr = Format(olMaxDuration, "hh:mm:ss") ' Convert olMaxDuration to a string


   ' olMaxDuration = olDuration

    ' Get the Outlook calendar folder
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderCalendar)
    Set olItems = olFolder.Items

    ' Apply filters to find available time slots
Dim n As Long
Debug.Print TimeValue(olDuration) 'this gives an answer of 01:00:00
 'Find the next available free time slot
olFilter = "[Start] >= '" & Format(Now(), "dd/mm/yyyy hh:mm:ss") & "'"
olFilter = olFilter & " And [End] <= '" & Format(DateAdd("d", 14, Now()), "dd/mm/yyyy hh:mm:ss") & "'"
olFilter = olFilter & " And [BusyStatus] = 0"
olFilter = olFilter & " And [Start] >= '" & Format(olStartTime, "hh:mm:ss") & "'"
olFilter = olFilter & " And [End] <= '" & Format(olEndTime, "hh:mm:ss") & "'"
'If TimeValue(olDuration) > TimeValue("00:00:00") Then
'    olFilter = olFilter & " And DateDiff('n', [Start], [End]) >= " & DateDiff("n", 0, TimeValue(olDuration))
'End If
'I'm not sure whether to include the above 3 lines - if I do then I get 'condition is not valid' at the next line. If I don't then the code can't find any appointments anyway (olRestrictItems.count = 0)

Set olRestrictItems = olItems.Restrict(olFilter)
    ' Sort the appointment items by start time
    olRestrictItems.Sort "[Start]"

    ' Create a new email object
    Set olEmail = olApp.CreateItem(olMailItem)
    With olEmail
        .Subject = "Available time slots"
        .Body = "Dear client," & vbCrLf & vbCrLf & "I am available at the following times within the next 2 weeks:" & vbCrLf & vbCrLf
        ' Insert the next 2 available time slots in the email body
        i = 1
        j = 1
        Do While i <= olRestrictItems.Count And j <= 1
            Set olItem = olRestrictItems.Item(i)
            If olItem.Start > Now() Then ' Only include appointments in the future
                strBody = Format(olItem.Start, "dd/mm/yyyy hh:mm:ss") & " to " & Format(DateAdd("h", olMaxDuration, olItem.Start), "hh:mm") & vbCrLf
                .Body = .Body & strBody
                j = j + 1
            End If
            i = i + 1
        Loop
        If j = 1 Then ' No available time slots found
            .Body = .Body & "Sorry, no available time slots were found within the next 2 weeks that match your requirements." & vbCrLf
        End If
        .Display ' Display the email
    End With

    ' Clean up
    Set olItem = Nothing
    Set olEmail = Nothing
    Set olRestrictItems = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

 

[RockEd]

Bump

 

[John_w]

You have two pairs of [Start] and [End] values in the olFilter string. Delete one pair.

 

[RockEd]

That didn't solve it unfortunately and for the life of me I couldn't get this to work. I just couldn't get any 'olRestrictItems' filled. In another version, again regardless of how strict or loose my criteria was it would bring in meetings that were in the past and not in a very good order. So I went back to the drawing board and finished this in backwards way - collated all of the busy appointments; put them into an array, sorted them and then checked for the free times (i.e. the times that I'm not in a meeting). Of course this just prints it to the immediate window but it won't take too much to put it into an email.

Last night it wasn't finding a free slot at 9am so if anyone can spot why that would be much appreciated! I can't change the clock at my work computer so it's difficult to test during the day.

Sub GetNextAvailableTimeSlot()

    Dim olApp As Object ' Outlook.Application
    Dim olNS As Object ' Outlook.Namespace
    Dim olFolder As Object ' Outlook.MAPIFolder
    Dim olRestrictItems As Object ' Outlook.Items
    Dim olAppt As Object ' Outlook.AppointmentItem
    Dim startDate As Date
    Dim endDate As Date
    Dim arrAppts() As Variant
    Dim i As Long
    Dim j As Long
    Dim temp As Variant
    Dim nextAvailableTime As Date
    Dim startTime As Date
    Dim endTime As Date
   
    ' Calculate the start and end times based on the current time
    If TimeValue(Now()) < TimeSerial(9, 0, 0) Then
        startTime = DateValue(Now()) + TimeSerial(9, 0, 0)
        endTime = DateValue(Now()) + TimeSerial(16, 0, 0)
    ElseIf TimeValue(Now()) >= TimeSerial(9, 0, 0) And TimeValue(Now()) < TimeSerial(16, 0, 0) Then
        startTime = DateValue(Now()) + TimeSerial(Int(Hour(Now()) / 2) * 2 + 2, 0, 0)
        endTime = DateValue(Now()) + TimeSerial(16, 0, 0)
    Else
        startTime = DateValue(Now()) + TimeSerial(9, 0, 0) + 1
        endTime = DateValue(Now()) + TimeSerial(16, 0, 0) + 1
    End If
   
    ' Create an instance of Outlook and set the namespace
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
   
    ' Get the calendar folder
    Set olFolder = olNS.GetDefaultFolder(9) ' 9 = olFolderCalendar
   
    ' Apply a restriction to the items in the folder
    Set olRestrictItems = olFolder.Items.Restrict("[Start] >= '" & Format(startTime, "ddddd h:nn AMPM") & "' And [Start] <= '" & Format(endTime, "ddddd h:nn AMPM") & "'")
   
    ' Loop through the restricted items and add the appointment details to an array
    For Each olAppt In olRestrictItems
        If olAppt.Start >= startTime Then
            ReDim Preserve arrAppts(i)
            arrAppts(i) = Array(olAppt.Start, olAppt.End)
            i = i + 1
        End If
    Next olAppt
   
    ' Sort the array based on the appointment start time in ascending order
    For i = LBound(arrAppts) To UBound(arrAppts) - 1
        For j = i + 1 To UBound(arrAppts)
            If arrAppts(j)(0) < arrAppts(i)(0) Then
                temp = arrAppts(i)
                arrAppts(i) = arrAppts(j)
                arrAppts(j) = temp
            End If
        Next j
    Next i
   
    ' Find the next available 1-hour time slot
    nextAvailableTime = startTime
    For i = LBound(arrAppts) To UBound(arrAppts)
        If nextAvailableTime < arrAppts(i)(0) Then
            If arrAppts(i)(0) - nextAvailableTime >= TimeSerial(1, 0, 0) Then
                Debug.Print "Next available time slot: " & Format(nextAvailableTime, "ddddd h:nn AMPM") & " - " & Format(DateAdd("h", 1, nextAvailableTime), "ddddd h:nn AMPM")
                Exit Sub
            Else
                nextAvailableTime = arrAppts(i)(1)
            End If
        Else
            nextAvailableTime = arrAppts(i)(1)
        End If
    Next i
   
    ' If no available time slot was found, print an error message
    Debug.Print "No available time slot found."
   
    ' Clean up
    Set olApp = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olRestrictItems = Nothing
    Set olAppt = Nothing
   
End Sub

'This doesn't find 9am slots for some reason though.

 

[John_w]

I had a closer look at your first code and simplified the filter to look at only the Start date-time of the free-time appointments in the next 2 weeks. The Now in [Start] >= '" & Format(Now, "ddddd hh:nn AMPM") ensures that only date-times in the future are captured, so there's no need to check that the appointment start time is in the future when creating the email. I also changed all the Outlook object variable names such as olApp to outApp, because the ol prefix is used by Outlook.

Option Explicit

Public Sub Find_Available_Time_Slots_and_Email()

    Dim outApp As Outlook.Application
    Dim outNS As Outlook.Namespace
    Dim outCalendarFolder As Outlook.Folder
    Dim outCalendarItems As Outlook.Items
    Dim outAppointmentItems As Outlook.Items
    Dim outAppointment As Outlook.AppointmentItem
    Dim outEmail As Outlook.MailItem
    Dim StartTime As Date, EndTime As Date, MaxDuration As Date
    Dim filter As String
    Dim i As Long, n As Long
    Dim strBody As String

    ' Define working hours and maximum duration
    StartTime = TimeValue("9:00:00 AM")
    EndTime = TimeValue("5:00:00 PM")
    MaxDuration = TimeValue("01:00:00")
    
    ' Get the Outlook calendar folder
    Set outApp = New Outlook.Application
    Set outNS = outApp.GetNamespace("MAPI")
    Set outCalendarFolder = outNS.GetDefaultFolder(olFolderCalendar)
    Set outCalendarItems = outCalendarFolder.Items

    ' Apply filters to find available time slots
     
    filter = "[Start] >= '" & Format(Now, "ddddd hh:nn AMPM") & "' AND [Start] <= '" & Format(Date + 14 + EndTime, "ddddd hh:nn AMPM") & "'"
    filter = filter & " AND [BusyStatus] = " & OlBusyStatus.olFree
    Debug.Print filter
    
    Set outAppointmentItems = outCalendarItems.Restrict(filter)
    
    ' Sort the appointment items by start time
    outAppointmentItems.Sort "[Start]"
    
    Debug.Print outAppointmentItems.Count
    For Each outAppointment In outAppointmentItems
        With outAppointment
            Debug.Print .Subject, .Start, .End, .BusyStatus
        End With
    Next
    
    ' Create a new email
    Set outEmail = outApp.CreateItem(olMailItem)
    With outEmail
        .Subject = "Available time slots"
        .Body = "Dear client," & vbCrLf & vbCrLf & "I am available at the following times within the next 2 weeks:" & vbCrLf & vbCrLf
        If outAppointmentItems.Count >= 1 Then
            ' Insert the next 2 available time slots in the email body
            i = 1
            n = 0
            Do While i <= outAppointmentItems.Count And n < 2
                Set outAppointment = outAppointmentItems.Item(i)
                strBody = Format(outAppointment.Start, "dd/mm/yyyy hh:mm") & " to " & Format(outAppointment.Start + MaxDuration, "hh:mm") & vbCrLf
                .Body = .Body & strBody
                i = i + 1
                n = n + 1
            Loop
        Else
            ' No available time slots found
            .Body = .Body & "Sorry, no available time slots were found within the next 2 weeks that match your requirements." & vbCrLf
        End If
        .Display ' Display the email
    End With

    ' Clean up
    Set outAppointment = Nothing
    Set outEmail = Nothing
    Set outAppointmentItems = Nothing
    Set outCalendarItems = Nothing
    Set outCalendarFolder = Nothing
    Set outNS = Nothing
    Set outApp = Nothing
   
End Sub

 

[RockEd]

Thank you! But it's still finding a date in the past - I've changed this line slightly in your response - I presume you were supposed to write End - either way it doesn't make a difference it's still finding a cancelled appointment on the 17th Jan 2023...!

From this:

    filter = "[Start] >= '" & Format(Now, "ddddd hh:nn AMPM") & "' AND [Start] <= '" & Format(Date + 14 + EndTime, "ddddd hh:nn AMPM") & "'"

To this:

    filter = "[Start] >= '" & Format(Now, "ddddd hh:nn AMPM") & "' AND [End] <= '" & Format(Now() + 14 + EndTime, "ddddd hh:nn AMPM") & "'"

 

[John_w]

I presume you were supposed to write End

No, the filter Start >= xxx And Start <= yyy is deliberate because you only need to look at appointments whose start times are from the current date-time to 14 days in the future at 5 PM. I think end times can be ignored.

Date + 14 + EndTime actually gives 15 days from the current date, so I think that part should be Date + 13 + EndTime.

If you want to include the End time then I think the filter should be:

    filter = "[Start] >= '" & Format(Now, "ddddd hh:nn AMPM") & "' AND [Start] <= '" & Format(Date + 13 + EndTime, "ddddd hh:nn AMPM") & "'"
    filter = filter & " AND [End] <= '" & Format(Date + 13 + EndTime, "ddddd hh:nn AMPM") & "'"
    filter = filter & " AND [BusyStatus] = " & OlBusyStatus.olFree

I can't explain why it's finding the cancelled appointment. Try sorting all the Calendar items by Start time before and after the Restrict filter:

    outCalendarItems.Sort "[Start]"
    Set outAppointmentItems = outCalendarItems.Restrict(filter)
   
    ' Sort the appointment items by start time
    outAppointmentItems.Sort "[Start]"

 

[RockEd]

Unfortunately I couldn't get this to work. It's still bringing in dates in the past; and it also is looking for "free" appointments in my calendar rather than empty slots. As my way above solves this, i think i'll just stick with that - albeit it will probably think "free appointments" are "appointments" and therefore I will be busy. However, I don't use my calendar to set "free appointments" so that shouldn't be an issue. thanks for your efforts though.

 

[RockEd]

Finally finished this using the help of this page:

VBA Express : Multiple Apps - Find Available Times between Appointments for Multiple Users

It's not yet displaying in an email - I will sort that later - but this will save the appointments to my calendar.

Option Explicit

Function FindFreeTime(dtmAppt As Date, dtmFirstAppt As Date, dtmLastAppt As Date, intDefaultAppt As Integer, i As Integer) As String
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Capture all available timeslots (between appointments)
     '               in a 2 week timeframe and book slots into calendar.
     '
     ' Inputs:       dtmAppt         Date to search
     '
     ' Assumptions:  * Free timeslot must be >= default appointment time
     '               * Free timeslot must be between default start and end times for
     '                 appointments
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    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 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

    Const C_Procedure = "FindFreeTime" ' Procedure name


    dtmNext = dtmFirstAppt

    If i = 0 And dtmFirstAppt < Now Then
        dtmNext = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
    End If


    On Error GoTo ErrHandler

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

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

    Set objNS = objOL.GetNamespace("MAPI")

    ' Get the local calendar folder
    Set OLFldr = objNS.GetDefaultFolder(olFolderCalendar)

    ' Get the appointments for the selected day
    Set OLAppts = OLFldr.Items.Restrict(strDay)

  '  dtmNext = C_dtmFirstAppt

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

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

    With OLAppts
         ' capture 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"))
           ' Debug.Print Format(OLAppt.Start, "Hh:Nn")
                
                    If Format(dtmNext, "Hh:Nn") < Format(OLAppt.Start, "Hh:Nn") Then

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

                         ' can we fit an appointment into the gap?
                        If intDuration >= intDefaultAppt Then
                    strList = strList & 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 > dtmLastAppt Then
                Exit Do
            End If
        End Select

        intDuration = 0

        Set OLAppt = .GetNext
        If dtmNext > dtmLastAppt Then
        Exit Do
    End If
'Debug.Print OLAppt = .Count

    Loop
End With

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

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

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

Sub ScheduleAppointments()
    Dim dtmFirstAppt As Date
    Dim dtmLastAppt As Date
    Dim intDefaultAppt As Integer

    ' Set the default values for appointment times and duration
    dtmFirstAppt = #9:00:00 AM#
    dtmLastAppt = #5:00:00 PM#
    intDefaultAppt = 60 ' in minutes

    ' Call the function to find and schedule appointments
    ScheduleFreeTimeAppointments dtmFirstAppt, dtmLastAppt, intDefaultAppt
End Sub
        
Function ScheduleOutlookAppointment(dtmStart As Date, dtmEnd As Date) As Boolean
    ' Create a new appointment in the default calendar folder
    On Error Resume Next 'to handle error if Outlook is not open
    Dim objOL As New Outlook.Application
    Dim objNS As Namespace
    Dim objAppt As AppointmentItem

    Set objNS = objOL.GetNamespace("MAPI")
    Set objAppt = objNS.GetDefaultFolder(olFolderCalendar).Items.Add(olAppointmentItem)

    With objAppt
        .Subject = "Scheduled appointment"
        .Start = dtmStart
        .End = dtmEnd
        .Save
    End With

    ScheduleOutlookAppointment = (Err.Number = 0) ' return True if no error occurred, False otherwise
    Err.Clear
End Function

Sub ScheduleFreeTimeAppointments(ByVal dtmFirstAppt As Date, ByVal dtmLastAppt As Date, ByVal intDefaultAppt As Integer)
    Dim strList     As String
    Dim dtmAppt     As Date
    Dim i           As Integer
    Dim found       As Integer
    Dim intCount    As Integer
    Dim dtmLastScheduled As Date

    ' Check if the first day should be skipped
    dtmAppt = Date
    If TimeValue(Now) > dtmLastAppt Then
        dtmAppt = DateAdd("d", 1, Date)
    End If

    For i = 0 To 13
        If i = 0 Then        ' First day
       ' If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmFirstAppt Then
        If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmLastAppt Then
            ' Current time is after dtmFirstAppt, so set dtmFirstAppt to the next whole hour
            dtmFirstAppt = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))

            Dim durDefaultAppt As Double
            Dim timeDefaultAppt As Date

            timeDefaultAppt = TimeValue(dtmFirstAppt)        ' Convert it into the time of day only.

            'Calculate the end of the appoint
            Dim timeEndAppt As Date
            timeEndAppt = DateAdd("n", intDefaultAppt, timeDefaultAppt)

            'Check if the end of the appointment is equal to or greater than the time of logging off.
            If timeEndAppt >= dtmLastAppt Then
                'if so then move on to the next day.
                i = 1
                'otherwise carry on
            End If
        End If
    Else        ' All other days
        dtmFirstAppt = #6:00:00 AM#
    End If
    If i > 0 Then


    dtmAppt = DateAdd("d", 1, dtmAppt)

    End If

    If Weekday(dtmAppt) >= 2 And Weekday(dtmAppt) <= 6 Then        ' Check if the date is a weekday
    strList = FindFreeTime(dtmAppt, dtmFirstAppt, dtmLastAppt, intDefaultAppt, i)
    If Len(strList) > 0 Then        ' A free timeslot was found
    'Debug.Print "Free timeslots found For " & Format(dtmAppt, "dd/mm/yyyy") & ":"
    'Debug.Print strList

    Dim arrSlots()  As String
    Dim j           As Integer
    Dim dtmStart    As Date
    Dim dtmEnd      As Date

    ' Schedule appointments for the free slots
    arrSlots = Split(strList, ";")
    For j = 0 To UBound(arrSlots) - 1 Step 2
        dtmStart = CDate(dtmAppt & " " & arrSlots(j))
        dtmEnd = CDate(dtmAppt & " " & arrSlots(j + 1))

        ' Check if the appointment is within the next two weeks
        
        If dtmStart >= Now() And dtmStart <= DateAdd("d", 14, Now()) Then
            If dtmStart >= DateAdd("d", 1, dtmLastScheduled) Then        ' Schedule appointment only if it's on a different day than the last scheduled appointment
            If ScheduleOutlookAppointment(dtmStart, DateAdd("n", intDefaultAppt, dtmStart)) Then        ' Set the appointment duration to intDefaultAppt
            intCount = intCount + 1
            dtmLastScheduled = dtmStart        ' Update the date of the last scheduled appointment

            ' Stop scheduling appointments once we've scheduled two
            If intCount = 2 Then
                Exit For
            End If
        Else
            Debug.Print "Error scheduling appointment For " & dtmStart
        End If
    End If
End If
Next j

found = found + 1
Else
   ' Debug.Print "No free timeslots found For " & Format(dtmAppt, "dd/mm/yyyy")
End If
Else
   ' Debug.Print "Skipping weekend day " & Format(dtmAppt, "dd/mm/yyyy")
End If

' Exit the loop if we've scheduled two appointments
If intCount = 2 Then
    Exit For
End If
Next i

' Notify the user if no appointments were scheduled
If intCount = 0 Then
    MsgBox "No available time slots found within the Next two weeks.", vbInformation
Else
    MsgBox intCount & " appointment(s) scheduled.", vbInformation
End If
End Sub