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
@KazJaw Ich habe es hinzugefügt - bitte helfen Sie, wenn Sie können. Vielen Dank! – todayspresent
Eine Frage wahrscheinlich ein wenig aus dem linken Feld, aber haben Sie erwogen, den VBA in Outlook statt in Excel zu schreiben? Das beiseite, aber für FreeBusy, hilft das? https://msdn.microsoft.com/en-us/library/office/aa220097(v=office.11).aspx Für das benutzerdefinierte Datetime-Format würden Sie eine Kombination aus der Format() -Funktion und String-Funktionen verwenden . Wenn Sie mit verschiedenen Zeitzonen arbeiten müssen, würden Sie auch eine Funktion schreiben, um alle in eine Standardzeitzone wie GMT/UTC zu konvertieren. – stifin