Frei/Gebucht-Zeiten für mehrere E-Mail-Adressen abrufen

Question

Ich plane Besprechungen mit 3-4 "beschäftigt" Menschen. Die Verwendung des Scheduling Assistant zum Abrufen und Aktualisieren verfügbarer Zeiten kann mühsam sein.

Ich versuche, ein Excel-Makro zu erstellen (mit Outlook geöffnet), um verfügbare Zeiten basierend auf den bereitgestellten E-Mail-Adressen anzuzeigen.

Dieses Makro erstellt eine Besprechung, wenn das Datum bekannt ist. Wenn das Datum nicht bekannt ist, muss ich die Daten, die alle frei haben, in die Tabelle drucken.
Alle Benutzer befinden sich auf demselben Server.

Sub GetFreeBusyInfo() ist, wo ich Hilfe brauche.
1. Es können individuelle Verfügbarkeit drucken - aber ich brauche die Frei/Gebucht-Informationen für die gesamte Gruppe
2. Wie kann ich die Ergebnisse in einem „2013.07.01 03.00 zeigen bekommen - 16:00 Uhr EST "Format?

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

Ich war in einem ähnlichen Problem interessiert, damit ich einige Code, der das Problem der Suche nach einer für beide Seiten verfügbaren Zeitschlitz für alle Empfänger, da Ihr Meeting Info löst schrieb.

Ich war mir nicht sicher, was genau Sie als Ausgabe wollten, also schreibt es jetzt einfach alle verfügbaren Zeiten in die oberste Zeile. Der Code kann leicht angepasst werden, um alle Zeitfenster und Frei/Belegt-Status für einzelne Empfänger anzuzeigen.

Die Gesamtstruktur des Codes ist:

Zuerst alle Empfänger Frei/Belegt-Status sammeln (wie du). Dies ist eine riesige Folge von Ziffern (0/1/2/3), die die Verfügbarkeit für den gegebenen Zeitraum darstellen (in gegebenen Dauer Intervallen). Beginnen Sie mit einem bestimmten Datum (heute), und Sie können die Minuten addieren, um für jedes Zeitfenster eine korrekte DateTime zu erhalten.

Speichern Sie alle Verfügbarkeitsinformationen in einer Sammlung von Arrays. Wahrscheinlich ein besserer Weg dies zu tun, aber ich wollte es einfach haben.

Gehen Sie durch jedes Zeitfenster und finden Sie einen Zeitpunkt, an dem alle Verfügbarkeitsfelder zu 0 (0 = Frei) addieren. Wenn dies der Fall ist, drucken Sie dieses bestimmte Zeitfenster aus und gehen Sie dann zum nächsten Zeitfenster.

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