在Excel中显示Outlook日历的打开时间段

Question

我创建了一个代码，显示与我共享日历的人员的打开时间段。在单元格中输入日期将显示雇员，开始时间，结束时间格式的列表框中的所有打开时间段。

该代码仅适用于本月15日及以后的代码。列表框的前15天显示上午9点至下午5点，不拉开空位。

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

它始终是日期格式

 ' 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"))