Sửa code : Lấy lịch trống trên outlook calendar bằng VBA (1 người xem)

[bigbabol89]

Hi các anh chị,
Em sưu tầm được file này từ google :
- Lấy thời gian trống của 1 người nào đó ( họ đã chia sẻ lịch ) trên calendar outlook trong 1 ngày theo khai báo ( từ 9h sáng -> 17h chiều )
Tuy nhiên, chỉ lấy dữ liệu trong 1 ngày thì em vẫn phải đi dò nhiều ngày liên tục. Vì vậy, nhờ các anh chị sửa giúp em là :
- Lấy thời gian trống của 1 người nào đó ( họ đã chia sẻ lịch ) trên calendar outlook trong 2 tuần tính từ ngày khai báo ( từ 9h sáng -> 17h chiều ), nếu thêm không tính giờ nghỉ trưa nữa thì tốt quá ạ.
Rất mong các anh chị giúp đỡ ạ.
Em cám ơn ạ.

Option Explicit

Private Sub cmdTimeslot_Click()
    Dim rng As Range                            ' Range listing employees
    Dim strEmp() As String                      ' Shared calendars
    Dim strTimeslot As String                   ' Available timeslots
    Dim i As Integer                            ' Counter
    Dim n As Integer                            ' Counter
   
   
    On Error Resume Next
    ActiveSheet.Range("dat_Timeslot").ClearContents
   
    On Error GoTo ErrHandler
    For Each rng In ActiveSheet.Range("lkp_Shared")
        ReDim Preserve strEmp(0 To i) As String
        strEmp(i) = rng.Formula
        i = i + 1
    Next rng
   
    strTimeslot = FindFreeTime(ActiveSheet.Range("lkp_Date").Value, strEmp())
   
    Do
        For i = 0 To 2
            Range("StartTimes").Offset(n - 1, i).Formula = Left(strTimeslot, InStr(1, strTimeslot, ";") - 1)
            strTimeslot = Mid(strTimeslot, InStr(1, strTimeslot, ";") + 1)
        Next i
       
        n = n + 1
    Loop Until InStr(1, strTimeslot, ";") = 0
   
    ActiveSheet.lstAvailable.ListFillRange = "dat_Timeslot"
   
    MsgBox "The list of available times for " & _
            Format(ActiveSheet.Range("lkp_Date").Value, "d-mmm-yyyy") & _
            " has been updated", vbInformation, "Available Timeslots"
   
   
ExitHere:
    Exit Sub
   
ErrHandler:
    MsgBox Err.Number & ": " & Err.Description
    Resume ExitHere
End Sub

Option Explicit

Function FindFreeTime(dtmAppt As Date, strEmp() As String) As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose:      Capture all available timeslots (between appointments) on
'               nominated day
'
' Inputs:       dtmAppt         Date to search
'               strEmp          Array containing all employee calendars to
'                                   search
'
' Assumptions:  * User must have access to the appropriate shared calendars in
'                 Outlook
'               * Free timeslot must be >= default appointment time
'               * Free timeslot must be between default start and end times for
'                 appointments
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    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 = #7:00:00 PM#      ' Last appointment time
    Const C_intDefaultAppt = 120            ' 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