I found the problem: the code reads the entire calendar for each appointment slot it checks, so checking the 9am slot takes twice as long as checking the 8.30am slot, checking the 9.30am slot takes three times as long, etc.
The new code looks like this:
BookNextFreeSlot is a sample of the code you need to produce to check for the next free slot on a
given day, and if one exists between
opening time and
closing time, book it with the specified
duration:-
Code:
[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys]Sub BookNextFreeSlot()[/FONT]
[FONT=Fixedsys] Dim dtDateToCheck As Date
Dim dtTimeToCheck As Date
Dim iDuration As Integer
Dim dtLastAppointment As Date
Dim dtNextFreeSlot As Date
dtDateToCheck = DateValue("[COLOR=red][B]26-Feb-2011[/B][/COLOR]")
dtTimeToCheck = TimeValue("[COLOR=darkorange][B]08:30:00[/B][/COLOR]")
iDuration = [/FONT][FONT=Fixedsys][COLOR=magenta][B]30
[/B][/COLOR] dtLastAppointment = TimeValue("[COLOR=blue][B]17:30:00[/B][/COLOR]")
dtNextFreeSlot = FindNextFreeSlot(dtDateToCheck + dtTimeToCheck, iDuration)
If dtNextFreeSlot > dtDateToCheck + dtLastAppointment + TimeSerial(0, 0, 1) Then
MsgBox "No free slots today!", vbOKOnly + vbExclamation
Else
If CreateAppointment(dtNextFreeSlot, iDuration) Then
MsgBox "Appointment for " & Format(dtNextFreeSlot, "hh:nn") _
& " on " & Format(dtNextFreeSlot, "d-mmm-yyyy") & " created", _
vbOKOnly + vbInformation
Else
MsgBox "Problem creating appointment for " & Format(dtNextFreeSlot, "hh:nn") _
& " on " & Format(dtNextFreeSlot, "d-mmm-yyyy"), vbOKOnly + vbExclamation
End If
End If[/FONT]
[FONT=Fixedsys]End Sub[/FONT]
FindNextFreeSlot is the procedure which returns the next free slot. It only reads the calendar once, storing the existing appointments for the specified day in an array, and then checks for free slots in the (very small and very fast) array.
Code:
[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys]Public Function FindNextFreeSlot(ByVal argCheckDateTime As Date, ByVal argDuration As Integer) As Date[/FONT]
[FONT=Fixedsys] Dim oApp As Outlook.Application
Dim oNameSpace As Outlook.Namespace
Dim oApptItem As Outlook.AppointmentItem
Dim oFolder As Outlook.MAPIFolder
Dim oMeetingoApptItem As Outlook.MeetingItem
Dim oObject As Object
Dim aStore() As Date
Dim iPtr As Integer
Dim bFound As Boolean
On Error Resume Next
' check if Outlook is running
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
'if not running, start it
Set oApp = CreateObject("Outlook.Application")
End If
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
ReDim aStore(0) As Date
For Each oObject In oFolder.Items
If oObject.Class = olAppointment Then
Set oApptItem = oObject
If Int(oApptItem.Start) = Int(argCheckDateTime) Then
ReDim Preserve aStore(UBound(aStore) + 1) As Date
aStore(UBound(aStore)) = oApptItem.Start
End If
End If
Next oObject
FindNextFreeSlot = argCheckDateTime
Do
iPtr = 1
bFound = False
For iPtr = 1 To UBound(aStore)
If Format(aStore(iPtr), "dd/mm/yyyy hh:nn:ss") = Format(FindNextFreeSlot, "dd/mm/yyyy hh:nn:ss") Then
bFound = True
Exit For
End If
Next iPtr
If bFound = False Then Exit Do
FindNextFreeSlot = FindNextFreeSlot + TimeSerial(0, argDuration, 0)
DoEvents
Loop
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function[/FONT]
And a slightly modified version of
CreateAppointment:-
Code:
[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys]Public Function CreateAppointment(ByVal argDateTime As Date, ByVal argDuration As Integer) As Long[/FONT]
[FONT=Fixedsys] Dim oApp As Outlook.Application
Dim oNameSpace As Namespace
Dim oItem As AppointmentItem
Dim iLastRow As Long
Dim irow As Long
On Error Resume Next
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
Set oApp = CreateObject("Outlook.Application")
End If
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oItem = oApp.CreateItem(olAppointmentItem)
With oItem
.Subject = "Slot booked"
.Start = argDateTime
.Duration = argDuration
.AllDayEvent = False
.Importance = olImportanceNormal
.Location = "Workshop"
.ReminderSet = False
.Save
End With
Set oApp = Nothing
Set oNameSpace = Nothing
Set oItem = Nothing[/FONT]
[FONT=Fixedsys] CreateAppointment = True
End Function[/FONT]
Hopefully you can put this lot together! Please let me know if it's any faster than the previous version?
