Question

我将代码放在一起，以便我可以通过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

使用VBA在Outlook中预订会议（按日期范围和检查可用性）

0 个答案: