Book meeting in Outlook with VBA (by date range and check availability)

[ferynd]

I put together code so that I could add my own appointments via an Excel tracking log to my calendar. This works great when I'm just putting basic appointments in. However, I'm often setting meetings with several people on my team throughout the week.


I would like to expand the code that I have below so that I can input a date range when I would be willing to have the meeting as well as the duration of the meeting, and then have it check each persons availability as well as a static list of meeting room resources and book the first option it comes across. I would have the rooms listed in order of preference.


As an example: I would like to be able to type in a list of names from my address book that will be attending a 1 hour meeting. It can happen anytime from 8am - 5pm on Friday. I would like the macro to pick the first available time slot where there is a meeting room available as well as each attendee is available and send out the meeting invite.


The code I currently have is below:

    Sub RegisterAppointmentList()
        ' adds a list of appontments to the Calendar in Outlook
        Dim olApp As Outlook.Application
        Dim olAppItem As Outlook.AppointmentItem
        Dim r As Long
            
        On Error Resume Next
        Worksheets("Schedule").Activate
    
        Set olApp = GetObject("", "Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            On Error Resume Next
            Set olApp = CreateObject("Outlook.Application")
            On Error GoTo 0
            If olApp Is Nothing Then
                MsgBox "Outlook is not available!"
                Exit Sub
            End If
        End If
        
        r = 3 'first row with appointment data in the active worksheet
        
        Do While Cells(r, 1).Value = "booked"
            r = r + 1
        Loop
        
        Dim mysub, myStart, myEnd
        While Len(Cells(r, 2).Text) <> 0
            mysub = Cells(r, 2) ' & ", " & Cells(r, 3)
            myStart = DateValue(Cells(r, 5).Value) + Cells(r, 12).Value
            myEnd = DateValue(Cells(r, 5).Value) + Cells(r, 13).Value
            'DeleteTestAppointments mysub, myStart, myEnd
            Set olAppItem = olApp.CreateItem(olAppointmentItem) 'creates a new appointment
            With olAppItem
                'set default appointment values
                .Location = Cells(r, 3)
                .Body = Cells(r, 4)
                .ReminderSet = True
                .BusyStatus = Cells(r, 14)
                '.RequiredAttendees = "johndoe@microsoft.com"
                On Error Resume Next
                .Start = myStart
                .End = myEnd
                .Subject = mysub
                '.Attachments.Add
                .Location = Cells(r, 3).Value
                .Body = .Subject & ", " & Chr(10) & Chr(10) & Cells(r, 4).Value
                .ReminderSet = True
                .BusyStatus = Cells(r, 14)
                .Categories = Cells(r, 10) 'add this to be able to delete the testappointments
                On Error GoTo 0
                .Save 'saves the new appointment to the default folder
            End With
            Cells(r, 1).Value = "booked"
            r = r + 1
        Wend
        Set olAppItem = Nothing
        Set olApp = Nothing
        MsgBox "Done !"
    End Sub