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

EN

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