ero interessato a un problema simile così ho scritto un codice che risolve il problema di trovare una fessura di tempo reciprocamente a disposizione per tutti i destinatari, dato il vostro informazioni riunione.
Non ero sicuro di cosa volessi esattamente come output, quindi adesso sto semplicemente scrivendo tutti i tempi disponibili sulla riga in alto. Il codice è facilmente regolabile per mostrare tutti gli intervalli di tempo e lo stato libero/occupato per i singoli destinatari.
La struttura complessiva del codice è:
primo luogo, raccogliere tutto lo stato destinatario libero/occupato (come avete fatto). Si tratta di una gigantesca stringa di cifre (0/1/2/3) che rappresenta la disponibilità per il periodo di tempo specificato (in intervalli di durata). Inizia da una data specifica (oggi) e puoi aggiungere i minuti per ottenere un DateTime appropriato per ogni fascia oraria.
Archiviare tutte le informazioni sulla disponibilità in una raccolta di array. Probabilmente un modo migliore per farlo, ma volevo che fosse semplice.
Attraversare ogni intervallo di tempo e trovare un momento in cui gli array di disponibilità di tutti sommano fino a 0 (0 = gratuito). In tal caso, stampare questa particolare fascia oraria e passare a quella successiva.
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 L'ho aggiunto, per favore aiutatemi se potete. Grazie! – todayspresent
Una domanda probabilmente un po 'da sinistra, ma hai pensato di scrivere il VBA in Outlook invece di Excel? A parte questo, per FreeBusy, questo aiuto? https://msdn.microsoft.com/en-us/library/office/aa220097(v=office.11).aspx Per il formato datetime personalizzato, si utilizzerà una combinazione della funzione format() e delle funzioni stringa . Se devi gestire diversi fusi orari, devi anche scrivere una funzione per convertirli tutti in un fuso orario standard come GMT/UTC. – stifin