Affichage des créneaux horaires ouverts pour le calendrier Outlook dans Excel

Question

J'ai créé un code qui affiche les créneaux horaires ouverts pour les personnes qui ont partagé leurs calendriers avec moi. La saisie d'une date dans une cellule affiche tous les intervalles de temps ouverts dans une zone de liste au format Employé, heure de début, heure de fin.

Le code ne fonctionne que si c'est le 15 du mois et plus tard. Pour les 15 premiers jours, la zone de liste affiche de 9h à 17h et ne tire pas les fentes ouvertes.

Option Explicit 

Dim objOL As New Outlook.Application ' Outlook 
Dim objNS As Namespace     ' Namespace 
Dim OLFldr As Outlook.MAPIFolder  ' Calendar folder 
Dim OLAppt As Object     ' Single appointment 
Dim OLRecip As Outlook.Recipient  ' Outlook user name 
Dim OLAppts As Outlook.Items   ' Appointment collection 
Dim strDay As String     ' Day for appointment 
Dim strList As String     ' List of all available timeslots 
Dim dtmNext As Date      ' Next available time 
Dim intDuration As Integer    ' Duration of free timeslot 
Dim i As Integer      ' Counter 

Const C_Procedure = "FindFreeTime"  ' Procedure name 
Const C_dtmFirstAppt = #9:00:00 AM#  ' First appointment time 
Const C_dtmLastAppt = #5:00:00 PM#  ' Last appointment time 
Const C_intDefaultAppt = 30    ' Default appointment duration 

On Error GoTo ErrHandler 

    ' list box column headings 
strList = "Employee;Start Time;End Time;" 

    ' get full span of selected day 
strDay = "[Start] >= '" & dtmAppt & "' and " & _ 
     "[Start] < '" & dtmAppt & " 11:59 pm'" 

    ' loop through shared Calendar for all Employees in array 
Set objNS = objOL.GetNamespace("MAPI") 

For i = 0 To UBound(strEmp) 
    On Error GoTo ErrHandler 
    Set OLRecip = objNS.CreateRecipient(strEmp(i)) 

    On Error Resume Next 
    Set OLFldr = objNS.GetSharedDefaultFolder(OLRecip, olFolderCalendar) 

     ' calendar not shared 
    If Err.Number <> 0 Then 
     strList = strList & strEmp(i) & _ 
      ";Calendar not shared;Calendar not shared;" 

     GoTo NextEmp 
    End If 

    On Error GoTo ErrHandler 
    Set OLAppts = OLFldr.Items 

    dtmNext = C_dtmFirstAppt 

     ' Sort the collection (required by IncludeRecurrences) 
    OLAppts.Sort "[Start]" 

     ' Make sure recurring appointments are included 
    OLAppts.IncludeRecurrences = True 

     ' Filter the collection to include only the day's appointments 
    Set OLAppts = OLAppts.Restrict(strDay) 

     ' Sort it again to put recurring appointments in correct order 
    OLAppts.Sort "[Start]" 

    With OLAppts 
      ' capture subject, start time and duration of each item 
     Set OLAppt = .GetFirst 

     Do While TypeName(OLAppt) <> "Nothing" 
       ' find first free timeslot 
      Select Case DateValue(dtmAppt) 
       Case DateValue(Format(OLAppt.Start, "dd/mm/yyyy")) 
        If Format(dtmNext, "Hh:Nn") < _ 
         Format(OLAppt.Start, "Hh:Nn") Then 

          ' find gap before next appointment starts 
         If Format(OLAppt.Start, "Hh:Nn") < _ 
           Format(C_dtmLastAppt, "Hh:Nn") Then 
          intDuration = DateDiff("n", dtmNext, _ 
              Format(OLAppt.Start, "Hh:Nn")) 
         Else 
          intDuration = DateDiff("n", dtmNext, _ 
              Format(C_dtmLastAppt, "Hh:Nn")) 
         End If 

          ' can we fit an appointment into the gap? 
         If intDuration >= C_intDefaultAppt Then 
          strList = strList & strEmp(i) & _ 
           ";" & Format(dtmNext, "Hh:Nn ampm") & _ 
           ";" & Format(DateAdd("n", intDuration, _ 
             dtmNext), "Hh:Nn ampm") & ";" 
         End If 
        End If 

         ' find first available time after appointment 
        dtmNext = DateAdd("n", OLAppt.Duration + intDuration, _ 
            dtmNext) 

         ' don't go beyond last possible appointment time 
        If dtmNext > C_dtmLastAppt Then 
         Exit Do 
        End If 
      End Select 

      intDuration = 0 

      Set OLAppt = .GetNext 
     Loop 
    End With 

     ' capture remainder of day 
    intDuration = DateDiff("n", dtmNext, Format(C_dtmLastAppt, "Hh:Nn")) 

    If intDuration >= C_intDefaultAppt Then 
     strList = strList & strEmp(i) & _ 
      ";" & Format(dtmNext, "Hh:Nn ampm") & _ 
      ";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & _ 
      ";" 
    End If 

NextEmp: 
    ' add note for unavailable Employee 
    If InStr(1, strList, strEmp(i)) = 0 Then 
     strList = strList & strEmp(i) & _ 
      ";Unavailable this day;Unavailable this day;" 
    End If 
Next i 

FindFreeTime = strList 

ExitHere: 
    On Error Resume Next 
    Set OLAppt = Nothing 
    Set OLAppts = Nothing 
    Set objNS = Nothing 
    Set objOL = Nothing 
    Exit Function 

ErrHandler: 
    MsgBox Err.Number & ": " & C_Procedure & vbCrLf & Err.Description 
    Resume ExitHere 
End Function 

Answer 1

Il est toujours le format de date

 ' Will likely be wrong from the 1st to the 12th day 
     Debug.Print " DateValue(Format(OLAppt.Start, dd/mm/yyyy)): " & DateValue(Format(OLAppt.start, "dd/mm/yyyy")) 

     ' Figure out the format that works for you 
     Debug.Print " DateValue(Format(OLAppt.Start, yyyy-mm-dd)): " & DateValue(Format(OLAppt.start, "yyyy-mm-dd")) 

     Select Case DateValue(dtmAppt) 

      'Case DateValue(Format(OLAppt.start, "dd/mm/yyyy")) 
      Case DateValue(Format(OLAppt.start, "yyyy-mm-dd"))