Retrieve free/busy times for multiple email addresses

Question

I schedule meetings with 3-4 "busy" people. Using the Scheduling Assistant for retrieving and updating available times can be tedious.

I am trying to create an Excel macro (with Outlook open) to view available times based on the email addresses provided.

This macro creates a meeting if date is known (done). If date is not known I need to print the dates everyone is free onto the spreadsheet.
All of the users are on the same server.

Sub GetFreeBusyInfo () is where I need help.
1. It can print individual availability - but I need the free/busy info for the entire group
2. How do I get the results to show in a "07/01/2013 3:00 - 4:00 PM EST" format?

Option Explicit
Sub CheckAvail()
Dim myOutlook As Object
Dim myMeet As Object
Dim i As Long

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
'Create the AppointmentItem
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1

i = 23
'Start at row 23
If Cells(i, 11) <> "" Then
    'Add Recipients
    Do Until Trim(Cells(i, 10).Value) = ""
       'Add all recipients
        myMeet.Recipients.Add Cells(i, 10)
        i = i + 1
    Loop

    i = 23
    myMeet.Start = Cells(i, 11).Value

    'Set the appointment properties
    myMeet.Subject = Cells(i, 12).Value
    myMeet.Location = Cells(i, 13).Value
    myMeet.Duration = Cells(i, 14).Value
    myMeet.ReminderMinutesBeforeStart = 88
    myMeet.BusyStatus = 2
    myMeet.Body = Cells(i, 15).Value
    myMeet.Save
    myMeet.Display

Else
   Call GetFreeBusyInfo

End If

End Sub

Public Sub GetFreeBusyInfo()
Dim myOutlook As Object
Dim myMeet As Object

Dim myNameSpace As Object
Dim myRecipient As Object
Dim myFBInfo As String, k As Long, j As Long, i As Long

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1
i = 23
Do Until Trim(Cells(i, 10).Value) = ""
    'Add all recipients
    myMeet.Recipients.Add Cells(i, 10)
    i = i + 1
Loop    

Set myNameSpace = myOutlook.GetNamespace("MAPI")
k = 1
i = 23
Do Until Trim(Cells(i, 10).Value) = ""
    k = k + 1
    Set myRecipient = myNameSpace.CreateRecipient(Cells(i, 10).Value)
    On Error GoTo ErrorHandler
    j = 2
    Cells(k, j) = Cells(i, 10).Value
    Do Until Trim(Cells(i, 10).Value) = ""
        myFBInfo = myRecipient.FreeBusy(#7/1/2013#, 60)
        j = j + 1
        Cells(k, j) = myFBInfo
        i = i + 1
    Loop
Loop
myMeet.Close
ErrorHandler:
    MsgBox "Cannot access the information. "
End Sub

Answer 1

I was interested in a similar problem so I wrote some code that solves the problem of finding a mutually available time slot for all recipients, given your meeting info.

I wasn't sure exactly what you wanted as output, so right now it is simply writing all available times out onto the top row. The code is easily adjusted to show all time slots and free/busy status for individual recipients.

The overall structure of the code is:

First, gather all recipient free/busy status (as you did). This is a giant string of digits (0/1/2/3) that represent availability for the given time period (in given duration intervals). Start from a given date (today) and you can add up the minutes to get a proper DateTime for each time slot.

Store all availability information in a collection of arrays. Probably a better way to do this but I wanted it to be straightforward.

Go through each time slot and find a time where everyone's availability arrays add up to 0 (0 = Free). When this is the case, print out this particular time slot and then move on to the next one.

Option Explicit

Sub CheckAvail()
Dim myOutlook As Object
Dim myMeet As Object
Dim i As Long

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
'Create the AppointmentItem
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1

i = 23
'Start at row 23
If Cells(i, 11) <> "" Then
    'Add Recipients
    Do Until Trim(Cells(i, 10).Value) = ""
       'Add all recipients
        myMeet.Recipients.Add Cells(i, 10)
        i = i + 1
    Loop

    i = 23
    myMeet.Start = Cells(i, 11).Value

    'Set the appointment properties
    myMeet.Subject = Cells(i, 12).Value
    myMeet.Location = Cells(i, 13).Value
    myMeet.Duration = Cells(i, 14).Value
    myMeet.ReminderMinutesBeforeStart = 88
    myMeet.BusyStatus = 2
    myMeet.Body = Cells(i, 15).Value
    myMeet.Save
    myMeet.Display

Else
   Call GetFreeBusyInfo

End If

End Sub

Public Sub GetFreeBusyInfo()
Dim myOutlook As Object
Dim myMeet As Object

Dim myNameSpace As Object
Dim myRecipient As Object
Dim i As Integer, totalMinutesElapsed As Long
Dim myMeetingDuration As Integer, intFreeBusy As Integer, intTimeslot As Integer, intEarliestHour As Integer, intLatestHour As Integer
Dim dtStartTime As Date, dtFinishTime As Date
Dim myFBInfo As String
Dim doHeaders As Boolean
Dim intFreeBusyCode As Integer

Dim recipStartRow As Integer
recipStartRow = 23 ' defined by question/asker

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1

myMeetingDuration = CInt(Cells(recipStartRow, 14).Value) ' same as above - need duration

'Add all recipients
i = 0
Do Until Trim(Cells(recipStartRow + i, 10).Value) = ""
    myMeet.Recipients.Add Cells(recipStartRow + i, 10)
    i = i + 1
Loop

Set myNameSpace = myOutlook.GetNamespace("MAPI")

' uncomment to have all possible timeslots write out
Dim debugRow As Integer, debugCol As Integer
debugRow = 2
debugCol = 2

' --> define the general 'working hours' here
' (anything timeslots that start before this period or end after this period will be ignored)
intEarliestHour = 8 '8am
intLatestHour = 17 '5pm

' set up structure to store free/busy info
Dim colAvailability As Collection, colRecipients As Collection
Dim strRecipientName As String
Dim arrayAvailability(1 To 1000) As Integer
Dim arrayStartDates(1 To 1000) As Date
Set colAvailability = New Collection
Set colRecipients = New Collection

' loop through each recipient (same as above)
doHeaders = True
i = 0
Do Until Trim(Cells(recipStartRow + i, 10).Value) = ""

    intTimeslot = 1

    strRecipientName = Cells(recipStartRow + i, 10).Value
    Set myRecipient = myNameSpace.CreateRecipient(strRecipientName)

    'Cells(debugRow + i, debugCol) = strRecipientName
    colRecipients.Add strRecipientName ' collections respect order of addition
    myFBInfo = myRecipient.FreeBusy(Date, myMeetingDuration, True)

    ' parse FB info string - stored as digits that represent Free/Busy constants, starting at midnight, in given time intervals
    For intFreeBusy = 1 To Len(myFBInfo)

        totalMinutesElapsed = CLng(intFreeBusy - 1) * myMeetingDuration

        dtStartTime = DateAdd("n", totalMinutesElapsed, Date)
        dtFinishTime = DateAdd("n", (totalMinutesElapsed + myMeetingDuration), Date)

        If Hour(dtStartTime) < intEarliestHour Or Hour(dtFinishTime) > intLatestHour Then

            ' skip this potential time slot
        Else

            intFreeBusyCode = CInt(Mid(myFBInfo, intFreeBusy, 1))

            ' Cells(debugRow + i, debugCol + intTimeslot) = GetFreeBusyStatus(intFreeBusyCode)
            arrayAvailability(intTimeslot) = intFreeBusyCode


            If doHeaders = True Then
                ' Cells(debugRow - 1, debugCol + intTimeslot) = dtStartTime
                arrayStartDates(intTimeslot) = dtStartTime
            End If

            intTimeslot = intTimeslot + 1

        End If

    Next intFreeBusy

    colAvailability.Add arrayAvailability ' save each recipients array of availability codes

    doHeaders = False
    i = i + 1
Loop

' search through each array to find times where everyone is available
For intTimeslot = 1 To 1000
    ' stop when we run out of time slots
    If arrayStartDates(intTimeslot) = #12:00:00 AM# Then
        Exit For
    End If

    dtStartTime = arrayStartDates(intTimeslot)

    ' loop through each meeting recipient at that time slot
    intFreeBusy = 0
    For i = 1 To colRecipients.Count
        intFreeBusy = intFreeBusy + colAvailability.Item(i)(intTimeslot)
    Next i

    If intFreeBusy = 0 Then ' everyone is free!
        debugCol = debugCol + 1
        Cells(debugRow - 1, debugCol).Value = dtStartTime


    End If

Next intTimeslot


'myMeet.Close


End Sub

Function GetFreeBusyStatus(code As Integer) As String

' https://msdn.microsoft.com/en-us/library/office/ff864234.aspx
' 0 = free
' 1 = tentative
' 2 = busy
' 3 = out of office
' 4 = "working elsewhere"

If code = 0 Then
    GetFreeBusyStatus = "Free"
ElseIf code = 1 Then
    GetFreeBusyStatus = "Tentative"
ElseIf code = 2 Then
    GetFreeBusyStatus = "Busy"
ElseIf code = 3 Then
    GetFreeBusyStatus = "Out"
ElseIf code = 4 Then
    GetFreeBusyStatus = "WFH"
Else
    GetFreeBusyStatus = "??"
End If

End Function