Option Explicit
Sub ContactDateCheck()
' mes rendez vous Outlook du jour
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myContacts As Outlook.Items
Dim myItems As Outlook.Items
Dim myItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
' Set MesRDV = myNamespace.GetDefaultFolder(olFolderCalendar).Items
Dim strDate As Variant, strRestriction As Variant
Dim myAppointments As Object, currentAppointment As Object
strDate = Range("D3")
strRestriction = "(([Start] >= '" & strDate & " 12:00 am' AND [Start] <= '" & strDate & " 11:59 pm')"
strRestriction = strRestriction & " OR ([End] > '" & strDate & " 12:00 am' AND [End] <= '" & strDate & " 11:59 pm')"
strRestriction = strRestriction & " OR ([Start] < '" & strDate & " 12:00 am' AND [End] > '" & strDate & " 11:59 pm'))"
strRestriction = strRestriction & " AND [Duration] > 0"
If strDate = "" Then strRestriction = "[Start] = 1" 'no result
Set myAppointments = myNamespace.GetDefaultFolder(olFolderCalendar).Items.Restrict(strRestriction)
myAppointments.Sort "[Start]"
' myAppointments.IncludeRecurrences = True
Dim CurApp
Dim DateStart As Date, DateEnd As Date
DateStart = strDate
Dim plage As Range, cel As Range
For Each currentAppointment In myAppointments
If currentAppointment.Class = olAppointment And currentAppointment.Start >= DateStart Then
DateStart = currentAppointment.Start
DateEnd = currentAppointment.End
Set plage = Range("a6:a28")
For Each cel In plage
If TimeSerial(Hour(cel), Minute(cel), 0) = TimeSerial(Hour(DateStart), Minute(DateStart), 0) Then
cel.Offset(0, 1) = currentAppointment.Subject
cel.Offset(0, 2) = Right(DateStart, 8)
End If
If TimeSerial(Hour(cel), Minute(cel), 0) = TimeSerial(Hour(DateEnd), Minute(DateEnd), 0) Then
cel.Offset(0, 1) = currentAppointment.Subject
cel.Offset(0, 2) = Right(DateEnd, 8)
End If
Next cel
End If
Next
End Sub