Multiple Apps

Find Available Times between Appointments for Multiple Users

Ease of Use

Intermediate

Version tested with

2003 

Submitted by:

geekgirlau

Description:

Search through a series of shared Calendars in Outlook for a free timeslot 

Discussion:

This function allows you to find available timeslots of a particular duration for all employees in a list. You pass the date and an array containing the employee names to the function, and it looks for free timeslots that are at least 2 hours in duration, between a set start and end time on that day. The duration and start/end times are constants, so you can change these values as appropriate. The function returns a string which is then used to populate a list box. This lists all available timeframes, and the user can then opt to create an appoinment in one of those timeframes. 

Code:

instructions for use

			

Option Explicit Function FindFreeTime(dtmAppt As Date, strEmp() As String) As String '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Purpose: Capture all available timeslots (between appointments) on ' nominated day ' ' Inputs: dtmAppt Date to search ' strEmp Array containing all employee calendars to ' search ' ' Assumptions: * User must have access to the appropriate shared calendars in ' Outlook ' * 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 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 = #7:00:00 PM# ' Last appointment time Const C_intDefaultAppt = 120 ' 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

How to use:

  1. Copy the function code above and paste it into a new module
  2. Select Tools | References
  3. Tick the reference to the Microsoft Outlook Object Library
  4. Save the module
  5. The function requires you to pass two values: the date you wish to search, and an array containing the names of the shared Calendars to search.
  6. The function is used to populate a list box on a form (see the "cmdTimeslot_Click" event in the form "frm_Appointment" in the attached sample file).
 

Test the code:

  1. ACCESS EXAMPLE
  2. Extract the sample database
  3. Open ShowTimeslott.mdb
  4. Open the module "bas_Appointment"
  5. Select Tools | References
  6. Make sure the Microsoft Outlook Object Library is ticked (this might state "Missing" depending on your version of Office, so you will have to select your current version)
  7. Open the table "tbl_Employee"
  8. Add your own name to the list of employees
  9. If you have access to any shared Calendars in Outlook, add one or more of these names to the list
  10. In Outlook, create one or more test appointments for tomorrow's date (if you don't already have some appointments)
  11. Open the form "frm_Appointment"
  12. Click on "Find Timeslot"
  13. A list of employee names from the table is displayed, along with any free timeslots on that date that are at least 2 hours in duration
  14. EXCEL EXAMPLE
  15. Extract the sample spreadsheet
  16. Open ShowTimeslot.xls
  17. Add your own name to the list of employees under "Shared Calendars"
  18. If you have access to any shared Calendars in Outlook, add one or more of these names to the list
  19. Enter a date to check in range "lkp_Date"
  20. Click on "Find Available Times"
  21. A list of employee names from is displayed, along with any free timeslots on that date that are at least 2 hours in duration
 

Sample File:

ShowTimeslot.zip 55.75KB 

Approved by mdmackillop


This entry has been viewed 150 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express