Return free 30 min intervals in Outlook using VBA

Question

Trying to include times I am free in text format for this or next week (e.g. Thursday May 11, 5:00-5:30 pm). Any way to insert that into an Outlook email?

Findpoll is bad UX and I don't want to share my whole calendar either.

Sub FindFreeTime()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim olAppt As Outlook.AppointmentItem
    Dim olItems As Outlook.Items
    Dim strFilter As String
    Dim dStart As Date
    Dim dEnd As Date
    Dim iDuration As Integer
    Dim FreeTimeMsg As String

    ' Set duration and working hours
    iDuration = 30
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderCalendar)
    Set olItems = olFolder.Items
    
    ' Filter to get this week's appointments
    dStart = Date + TimeValue("10:00:00")
    dEnd = Date + TimeValue("17:00:00")
    strFilter = "[Start] >= '" & Format(dStart, "mm/dd/yyyy hh:mm AMPM") & "'" _
               & " AND [Start] < '" & Format(dStart + 7, "mm/dd/yyyy hh:mm AMPM") & "'"
    Set olItems = olItems.Restrict(strFilter)
    olItems.Sort "[Start]"
    
    ' Check each 30 minute block for a free time
    Do While dStart < (Date + 7)
        If TimeValue(dStart) >= TimeValue("10:00:00") And TimeValue(dStart) < TimeValue("17:00:00") Then
            Set olAppt = olItems.Find("[Start] <= '" & Format(dStart, "mm/dd/yyyy hh:mm AMPM") _
                                    & "' AND [End] > '" & Format(dStart, "mm/dd/yyyy hh:mm AMPM") & "'")
            If olAppt Is Nothing Then
                FreeTimeMsg = FreeTimeMsg & Format(dStart, "mm/dd/yyyy hh:mm AMPM") & vbCrLf
            End If
        End If
        dStart = dStart + (iDuration / (24 * 60))
    Loop
    
    ' Create a new mail item and show the free time
    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .Subject = "My Free Time Slots"
        .Body = "Here are my free time slots for the upcoming week:" & vbCrLf & FreeTimeMsg
        .Display
    End With

    Set olAppt = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Answer 1

You can use the Recipient.FreeBusy method which returns free/busy information for the recipient (a string value that represents the free/busy information).

The default is to return a string representing one month of free/busy information compatible with the Microsoft Schedule+ Automation format (that is, the string contains one character for each MinPerChar minute, up to one month of information from the specified Start date).

If the optional argument CompleteFormat is omitted or False, then "free" is indicated by the character 0 and all other states by the character 1.

Set myRecipient = myNameSpace.CreateRecipient("Eugene Astafiev") 
myFBInfo = myRecipient.FreeBusy(#5/25/23#, 30, True)