Sub getFreeBusy() 

'This script finds the next time slot where at least 85% (or any other percentage) of the required persons are free
'Outlook itself only picks the next time slot where 100% of the participants are free.
'created by Nick Römer
'niveauverleih.blogspot.com

'TODO: Change this to match the participants of the meeting you want to organize
strUsersToCheck = "John Doe; Hans Mustermann; Jacques Dupont; Giacomo Pizzini"

intMeetingDuration = 120 'duration of meeting in minutes 
minimumParticipation = 0.85 'minimum percentage of invitees that need to be present, 0.85 = 85% 
                           'tentative commitments count as "half present" 
startHour = 9 
EndHour = 17 
intBaseUnit = 30    'granularity of free busy info in minutes 

'some derived parameters 
intFreeBlocks = Int(intMeetingDuration / intBaseUnit) 'number of blocks required for meeting 
intTotalBlocks = 44640 / intBaseUnit 
busyParticipantsRatio = 1 - minimumParticipation 'maximum percentage of invitees that can be absent 
strFBFrom = CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) 

Dim objRecipient As Recipient 
Dim summedfreebusy(44640) 'array will contain the sum of the freebusy values for all users 

Set objNewMsg = CreateItem(olMailItem) 
objNewMsg.To = strUsersToCheck 
Set objRecipients = objNewMsg.Recipients 
objRecipients.ResolveAll 
nb_users = objRecipients.Count 

'LOOP adding up freebusy info for all users for the coming months
'**************************************************************** 
For Each objRecipient In objRecipients 
    'in case that freebusy cannot be retrieved for the user, set all time as "tentative" 
    fbstring = String(intTotalBlocks, "1") 
    On Error Resume Next 
        fbstring = objRecipient.FreeBusy(strFBFrom, intBaseUnit, True) 
    On Error GoTo 0 
    fbnormalized = Replace(fbstring, "3", "2") 	'Out-of-office and busy should have the same value 2 
						'for our purposes
    For i = 1 To Len(fbstring) 
        summedfreebusy(i) = CInt(Mid(fbnormalized, i, 1)) + summedfreebusy(i) 
    Next 
Next 

 intAdjacentBlocks = 0 


'LOOP finding first timeslot that fits 85% of participants
'********************************************************* 
For i = 1 To intTotalBlocks 
    
    tempdate = DateAdd("n", (i - 1) * intBaseUnit, strFBFrom) 
    temphour = Hour(tempdate) 
    tempEndHour = Hour(DateAdd("n", intBaseUnit, tempdate)) + Minute(DateAdd("n", intBaseUnit, tempdate)) / 60 
    tempweekday = Weekday(tempdate) 
    tempratio = summedfreebusy(i) / 2 / nb_users 
    
    If temphour >= startHour And temphour <= EndHour And tempEndHour <= EndHour _ 
    And tempweekday <> vbSunday And tempweekday <> vbSaturday And tempratio <= busyParticipantsRatio Then 
        'logic that checks how many adjacent blocks of free time there are 
        intAdjacentBlocks = intAdjacentBlocks + 1 
        If i - lastBlock <> 1 Then intAdjacentBlocks = 0 
        lastBlock = i 
            
        
        If intAdjacentBlocks >= intFreeBlocks - 1 Then 
            tempdateEND = DateAdd("n", intBaseUnit, tempdate) 
            tempdateSTART = DateAdd("n", intBaseUnit + intMeetingDuration * -1, tempdate) 
            result = MsgBox("Next free time: " & _ 
            Day(tempdate) & "/" & Month(tempdateSTART) & " " & Hour(tempdateSTART) & ":" & Left(CStr(Minute(tempdateSTART)) & "0", 2) & _

             "-" & Hour(tempdateEND) & ":" & Left(CStr(Minute(tempdateEND)) & "0", 2) & _ 
             vbCr & vbCr & "Show more dates?", vbYesNo) 
             If result = vbNo Then Exit Sub 
        End If 
    End If 
Next 

MsgBox "done" 

Set objNewMsg = Nothing 
Set objRecipients = Nothing 

End Sub