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

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

1 个答案: