检索多个电子邮件地址的忙/闲时间

Question

我安排与3-4个"忙碌"的人会面.使用Scheduling Assistant检索和更新可用时间可能很繁琐.

我正在尝试创建一个Excel宏(Outlook打开),以根据提供的电子邮件地址查看可用时间.

如果日期已知(已完成),此宏将创建会议.如果日期未知,我需要将每个人都可以免费的日期打印到电子表格中.
所有用户都在同一台服务器上.

Sub GetFreeBusyInfo ()是我需要帮助的地方.
1.它可以打印个人可用性 - 但我需要整个组的忙/闲信息
2.如何在"07/01/2013 3:00 - 4:00 PM EST"格式中显示结果？

Option Explicit
Sub CheckAvail()
Dim myOutlook As Object
Dim myMeet As Object
Dim i As Long

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
'Create the AppointmentItem
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1

i = 23
'Start at row 23
If Cells(i, 11) <> "" Then
    'Add Recipients
    Do Until Trim(Cells(i, 10).Value) = ""
       'Add all recipients
        myMeet.Recipients.Add Cells(i, 10)
        i = i + 1
    Loop

    i = 23
    myMeet.Start = Cells(i, 11).Value

    'Set the appointment properties
    myMeet.Subject = Cells(i, 12).Value
    myMeet.Location = Cells(i, 13).Value
    myMeet.Duration = Cells(i, 14).Value
    myMeet.ReminderMinutesBeforeStart = 88
    myMeet.BusyStatus = 2
    myMeet.Body = Cells(i, 15).Value
    myMeet.Save
    myMeet.Display

Else
   Call GetFreeBusyInfo

End If

End Sub

Public Sub GetFreeBusyInfo()
Dim myOutlook As Object
Dim myMeet As Object

Dim myNameSpace As Object
Dim myRecipient As Object
Dim myFBInfo As String, k As Long, j As Long, i As Long

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1
i = 23
Do Until Trim(Cells(i, 10).Value) = ""
    'Add all recipients
    myMeet.Recipients.Add Cells(i, 10)
    i = i + 1
Loop    

Set myNameSpace = myOutlook.GetNamespace("MAPI")
k = 1
i = 23
Do Until Trim(Cells(i, 10).Value) = ""
    k = k + 1
    Set myRecipient = myNameSpace.CreateRecipient(Cells(i, 10).Value)
    On Error GoTo ErrorHandler
    j = 2
    Cells(k, j) = Cells(i, 10).Value
    Do Until Trim(Cells(i, 10).Value) = ""
        myFBInfo = myRecipient.FreeBusy(#7/1/2013#, 60)
        j = j + 1
        Cells(k, j) = myFBInfo
        i = i + 1
    Loop
Loop
myMeet.Close
ErrorHandler:
    MsgBox "Cannot access the information. "
End Sub

Answer 1

我对类似的问题感兴趣，因此我编写了一些代码来解决根据您的会议信息为所有收件人找到相互可用的时间段的问题。

我不确定您到底想要什么输出，所以现在它只是将所有可用的时间写入顶行。该代码可以轻松调整，以显示各个收件人的所有时间段和忙/闲状态。

代码整体结构为：

首先，收集所有收件人忙/闲状态（就像您所做的那样）。这是一串巨大的数字 (0/1/2/3)，表示给定时间段（给定的持续时间间隔）内的可用性。从给定日期（今天）开始，您可以将分钟相加以获得每个时间段的正确日期时间。

将所有可用性信息存储在数组集合中。可能是更好的方法，但我希望它简单明了。

遍历每个时间段并找到每个人的可用性数组加起来为 0 的时间（0 = 空闲）。在这种情况下，打印出这个特定的时间段，然后转到下一个时间段。

Option Explicit

Sub CheckAvail()
Dim myOutlook As Object
Dim myMeet As Object
Dim i As Long

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
'Create the AppointmentItem
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1

i = 23
'Start at row 23
If Cells(i, 11) <> "" Then
    'Add Recipients
    Do Until Trim(Cells(i, 10).Value) = ""
       'Add all recipients
        myMeet.Recipients.Add Cells(i, 10)
        i = i + 1
    Loop

    i = 23
    myMeet.Start = Cells(i, 11).Value

    'Set the appointment properties
    myMeet.Subject = Cells(i, 12).Value
    myMeet.Location = Cells(i, 13).Value
    myMeet.Duration = Cells(i, 14).Value
    myMeet.ReminderMinutesBeforeStart = 88
    myMeet.BusyStatus = 2
    myMeet.Body = Cells(i, 15).Value
    myMeet.Save
    myMeet.Display

Else
   Call GetFreeBusyInfo

End If

End Sub

Public Sub GetFreeBusyInfo()
Dim myOutlook As Object
Dim myMeet As Object

Dim myNameSpace As Object
Dim myRecipient As Object
Dim i As Integer, totalMinutesElapsed As Long
Dim myMeetingDuration As Integer, intFreeBusy As Integer, intTimeslot As Integer, intEarliestHour As Integer, intLatestHour As Integer
Dim dtStartTime As Date, dtFinishTime As Date
Dim myFBInfo As String
Dim doHeaders As Boolean
Dim intFreeBusyCode As Integer

Dim recipStartRow As Integer
recipStartRow = 23 ' defined by question/asker

'Create the Outlook Session
Set myOutlook = CreateObject("Outlook.Application")
Set myMeet = myOutlook.CreateItem(1)
myMeet.MeetingStatus = 1

myMeetingDuration = CInt(Cells(recipStartRow, 14).Value) ' same as above - need duration

'Add all recipients
i = 0
Do Until Trim(Cells(recipStartRow + i, 10).Value) = ""
    myMeet.Recipients.Add Cells(recipStartRow + i, 10)
    i = i + 1
Loop

Set myNameSpace = myOutlook.GetNamespace("MAPI")

' uncomment to have all possible timeslots write out
Dim debugRow As Integer, debugCol As Integer
debugRow = 2
debugCol = 2

' --> define the general 'working hours' here
' (anything timeslots that start before this period or end after this period will be ignored)
intEarliestHour = 8 '8am
intLatestHour = 17 '5pm

' set up structure to store free/busy info
Dim colAvailability As Collection, colRecipients As Collection
Dim strRecipientName As String
Dim arrayAvailability(1 To 1000) As Integer
Dim arrayStartDates(1 To 1000) As Date
Set colAvailability = New Collection
Set colRecipients = New Collection

' loop through each recipient (same as above)
doHeaders = True
i = 0
Do Until Trim(Cells(recipStartRow + i, 10).Value) = ""

    intTimeslot = 1

    strRecipientName = Cells(recipStartRow + i, 10).Value
    Set myRecipient = myNameSpace.CreateRecipient(strRecipientName)

    'Cells(debugRow + i, debugCol) = strRecipientName
    colRecipients.Add strRecipientName ' collections respect order of addition
    myFBInfo = myRecipient.FreeBusy(Date, myMeetingDuration, True)

    ' parse FB info string - stored as digits that represent Free/Busy constants, starting at midnight, in given time intervals
    For intFreeBusy = 1 To Len(myFBInfo)

        totalMinutesElapsed = CLng(intFreeBusy - 1) * myMeetingDuration

        dtStartTime = DateAdd("n", totalMinutesElapsed, Date)
        dtFinishTime = DateAdd("n", (totalMinutesElapsed + myMeetingDuration), Date)

        If Hour(dtStartTime) < intEarliestHour Or Hour(dtFinishTime) > intLatestHour Then

            ' skip this potential time slot
        Else

            intFreeBusyCode = CInt(Mid(myFBInfo, intFreeBusy, 1))

            ' Cells(debugRow + i, debugCol + intTimeslot) = GetFreeBusyStatus(intFreeBusyCode)
            arrayAvailability(intTimeslot) = intFreeBusyCode


            If doHeaders = True Then
                ' Cells(debugRow - 1, debugCol + intTimeslot) = dtStartTime
                arrayStartDates(intTimeslot) = dtStartTime
            End If

            intTimeslot = intTimeslot + 1

        End If

    Next intFreeBusy

    colAvailability.Add arrayAvailability ' save each recipients array of availability codes

    doHeaders = False
    i = i + 1
Loop

' search through each array to find times where everyone is available
For intTimeslot = 1 To 1000
    ' stop when we run out of time slots
    If arrayStartDates(intTimeslot) = #12:00:00 AM# Then
        Exit For
    End If

    dtStartTime = arrayStartDates(intTimeslot)

    ' loop through each meeting recipient at that time slot
    intFreeBusy = 0
    For i = 1 To colRecipients.Count
        intFreeBusy = intFreeBusy + colAvailability.Item(i)(intTimeslot)
    Next i

    If intFreeBusy = 0 Then ' everyone is free!
        debugCol = debugCol + 1
        Cells(debugRow - 1, debugCol).Value = dtStartTime


    End If

Next intTimeslot


'myMeet.Close


End Sub

Function GetFreeBusyStatus(code As Integer) As String

' https://msdn.microsoft.com/en-us/library/office/ff864234.aspx
' 0 = free
' 1 = tentative
' 2 = busy
' 3 = out of office
' 4 = "working elsewhere"

If code = 0 Then
    GetFreeBusyStatus = "Free"
ElseIf code = 1 Then
    GetFreeBusyStatus = "Tentative"
ElseIf code = 2 Then
    GetFreeBusyStatus = "Busy"
ElseIf code = 3 Then
    GetFreeBusyStatus = "Out"
ElseIf code = 4 Then
    GetFreeBusyStatus = "WFH"
Else
    GetFreeBusyStatus = "??"
End If

End Function