Option Explicit
Function FindFreeTime(dtmAppt As Date, strEmp() As String) As String
Dim objOL As New Outlook.Application
Dim objNS As Namespace
Dim OLFldr As Outlook.MAPIFolder
Dim OLAppt As Object
Dim OLRecip As Outlook.Recipient
Dim OLAppts As Outlook.Items
Dim strDay As String
Dim strList As String
Dim dtmNext As Date
Dim intDuration As Integer
Dim i As Integer
Const C_Procedure = "FindFreeTime"
Const C_dtmFirstAppt = #9:00:00 AM#
Const C_dtmLastAppt = #7:00:00 PM#
Const C_intDefaultAppt = 120
On Error GoTo ErrHandler
strList = "Employee;Start Time;End Time;"
strDay = "[Start] >= '" & dtmAppt & "' and " & _
"[Start] < '" & dtmAppt & " 11:59 pm'"
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)
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
OLAppts.Sort "[Start]"
OLAppts.IncludeRecurrences = True
Set OLAppts = OLAppts.Restrict(strDay)
OLAppts.Sort "[Start]"
With OLAppts
Set OLAppt = .GetFirst
Do While TypeName(OLAppt) <> "Nothing"
Select Case DateValue(dtmAppt)
Case DateValue(Format(OLAppt.Start, "dd/mm/yyyy"))
If Format(dtmNext, "Hh:Nn") < _
Format(OLAppt.Start, "Hh:Nn") Then
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
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
dtmNext = DateAdd("n", OLAppt.Duration + intDuration, _
dtmNext)
If dtmNext > C_dtmLastAppt Then
Exit Do
End If
End Select
intDuration = 0
Set OLAppt = .GetNext
Loop
End With
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:
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
|