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

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

1 个答案: