0
我創建了一個代碼,顯示與我共享日曆的人員的打開時間段。在單元格中輸入日期將顯示僱員,開始時間,結束時間格式的列表框中的所有打開時間段。在Excel中顯示Outlook日曆的打開時間段
該代碼僅適用於本月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
它的工作!就像你說的那樣是日期的格式。我將其更改爲您提供的格式:yyyy-mm-dd。非常感謝你的幫助 –