使用 VBA 在 Outlook 中召开会议(按日期范围和可用性)

我整理了代码，以便可以通过 Excel 跟踪日志将自己的约会添加到日历中。当我只需要进行基本约会时，这种方法就很好用。但是，我经常在一周中与团队中的几个人开会。

我想扩展下面的代码，以便我可以输入愿意参加会议的日期范围以及会议的持续时间，然后检查每个人的空闲时间和静态时间。会议室资源列表，并预定遇到的第一个选项。我会按优先顺序列出房间。

例如：我希望能够输入将参加 1 小时会议的通讯录中的姓名列表。它可以在星期五上午 8 点至下午 5 点之间的任何时间发生。我希望宏选择第一个可用的时隙，其中有一个会议室可用，并且每个与会者都有空，然后发出会议邀请。

我目前拥有的代码如下：

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