I was trying to create a scheduling application that would work with other users accounts. I found code here to add an appointment, however there was nothing to signal whether the times selected were available. I adapted the code below to run checks on the start/end times in the specified users calendar.
Edit:
After further testing I found that the function will return blank ("") if there are no appointments in the calendar. You could test for this on the calling side, but I added the following code after the For loop and before the Exit Function call:
Code:
Public Function CheckIsAvailable(strName As String, datStart As Date, datEnd As Date) As String
'---------------------------------------------------------------------------------------
' Procedure : CheckIsAvailable
' Author : TJ Poorman
' Purpose : To check if a Date/Time is available in specified users Outlook calendar
' Arguments : strName - The full email address of the calendar being checked
' datStart - Full Date/Time start of appointment
' datEnd - Fulle Date/Time end of appointment
' Returns : "Conflict" if busy during selected time frame
' "Possible Conflict" if tentative during selected time frame
' "Available" if available during selected time frame
' Example : CheckIsAvailable("user@domain.com", #1/1/2013 8:00:00 AM#, #1//2013 10:00:00 AM#)
'---------------------------------------------------------------------------------------
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colCal As Outlook.Items
Dim strFind As String
Dim colMyAppts As Outlook.Items
Dim objAppt As Outlook.AppointmentItem
Dim objFolder As Outlook.MAPIFolder 'Other persons folder
Dim objRecip As Outlook.Recipient 'Other persons name
On Error GoTo Find_Events_Err
'*****Verify the dates entered*****
If datStart < Now() Then 'The start date/time must be in the future
MsgBox "The starting Date/Time must be in the future"
GoTo Find_Events_Exit
End If
If datEnd < datStart Then 'The end date/time must be after the start
MsgBox "The ending Date/Time must be after the starting Date/Time"
GoTo Find_Events_Exit
End If
'**********************************
If isAppThere("Outlook.Application") = False Then
Set objApp = CreateObject("Outlook.Application") ' Outlook is not open, create a new instance
Else
Set objApp = GetObject(, "Outlook.Application") ' Outlook is already open--use this method
End If
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objRecip = objNS.CreateRecipient(strName)
Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)
If objFolder Is Nothing Then 'Check if the function has access to the other person's calendar
MsgBox "No access to the selected users calendar"
GoTo Find_Events_Exit
End If
Set colCal = objFolder.Items
colCal.Sort "[Start]", False
colCal.IncludeRecurrences = True
'Get all appointments that are not ended yet and all appointments in the future
strFind = "([Start] < " & Quote(Format(datStart, "dd mmm yyyy hh:mm AMPM")) & " AND [End] > " & Quote(Format(Now(), "dd mmm yyyy hh:mm AMPM")) & ")" & _
" OR ([Start] > " & Quote(Format(Now(), "dd mmm yyyy hh:mm AMPM")) & ")"
Set colMyAppts = colCal.Restrict(strFind)
For Each objAppt In colMyAppts
If (datStart > objAppt.Start And datStart < objAppt.End) Or (datEnd > objAppt.Start And datEnd < objAppt.End) Then
If objAppt.BusyStatus = olBusy Or objAppt.BusyStatus = olOutOfOffice Then 'Check the status. If Busy or OutOfOffice then conflict
CheckIsAvailable = "Conflict"
Exit For
' Debug.Print "Subj: " & objAppt.Subject & " Date: " & objAppt.Start & "-" & objAppt.End & "--CONFLICT"
ElseIf objAppt.BusyStatus = olTentative Then 'The status is Tentative so this time may be available.
CheckIsAvailable = "Possible Conflict"
Exit For
' Debug.Print "Subj: " & objAppt.Subject & " Date: " & objAppt.Start & "-" & objAppt.End & "--POSSIBLE CONFLICT"
End If
Else
CheckIsAvailable = "Available"
' Debug.Print "Subj: " & objAppt.Subject & " Date: " & objAppt.Start & "-" & objAppt.End & "--ACCEPTABLE"
End If
Next
Find_Events_Exit:
Set colMyAppts = Nothing
Set objNS = Nothing
Set colCal = Nothing
Set colMyAppts = Nothing
Set objAppt = Nothing
Set objApp = Nothing
Exit Function
Find_Events_Err:
MsgBox Error$
Resume Find_Events_Exit
End Function
Public Function Quote(MyText As String) As String
Quote = Chr(34) & MyText & Chr(34)
End Function
Public Function isAppThere(appName) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : isAppThere
' Author : Rick Dobson, Ph.D - Programming Microsoft Access 2000
' Purpose : To check if an Application is Open
' Arguments : appName The name of the Application
' Example : isAppThere("Outlook.Application")
'---------------------------------------------------------------------------------------
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, appName)
If Err.Number = 0 Then isAppThere = True
End FunctionEdit:
After further testing I found that the function will return blank ("") if there are no appointments in the calendar. You could test for this on the calling side, but I added the following code after the For loop and before the Exit Function call:
Code:
If CheckIsAvailable = "" Then CheckIsAvailable = "Available" 'If there is nothing, then this means there were no active appointments so it is available
Last edited:
