Microsoft 365 Renvoyer une date automatiquement

Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
On Error Resume Next
Worksheets("Schedule").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
r = 6 ' first row with appointment data in the active worksheet
Dim mysub, myStart, myEnd
While Len(Cells(r, 2).Text) <> 0
mysub = Cells(r, 2) & ", " & Cells(r, 3)
myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
myEnd = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value
'DeleteTestAppointments mysub, myStart, myEnd
Set olAppItem = olApp.CreateItem(olAppointmentItem)
' creates a new appointment
With olAppItem             ' set default appointment values
.Location = Cells(r, 3)
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
'.RequiredAttendees = "johndoe\@microsoft.com"
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = Cells(r, 2) & ", " & .Location
.Attachments.Add ("c:\temp\somefile.msg")
.Location = Cells(r, 3).Value
.Body = .Subject & ", " & Cells(r, 4).Value
.ReminderSet = True
.BusyStatus = olBusy
.Categories = "Orange Category" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
MsgBox "Done !"
End Sub