Private Sub calendrier_Click()
Dim DateDebut As String
Dim OutlApp As New Outlook.Application
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
Dim myOlApp As New Outlook.Application
Dim MyItem As Outlook.AppointmentItem
Dim myNamespace As Outlook.Namespace
Dim Cell As Range
Dim cal As String
'plage de donnée
cal = Sheets("Menu").Range("P3")
For Each Cell In Sheets(cal).Range("E2:E60")
'fin de plage de donnée
If Cell <> "" Then 'recherche dans la plage si il existe des données à inscrire
DateDebut = Cell.Offset(0, -2) & " " & Cell.Offset(0, -1) 'date pour vérification de doublons
'verifie s'il y a des doublons
On Error Resume Next
Set OutlAppointment = OutlItems.Find("[Start] = '" & DateDebut & "'")
On Error GoTo 0
'fin vérification doublon
If OutlAppointment Is Nothing Then 's'il n'y a pas de doublons lancement du code
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
Set MyItem = myOlApp.CreateItem(olAppointmentItem)
With MyItem 'inscription des données dans excel
.MeetingStatus = olNonMeeting 'meeting
.ReminderSet = False ' S'il y a un rappel
.Subject = Cell.Offset(0, 2) 'Sujet
.start = Cell.Offset(0, -2) & " " & Cell.Offset(0, -1) ' Date plus heure. Attention : format mm/dd/yy
.AllDayEvent = False ' Toute la journée oui/non
.Duration = 105 'minutes"
.Location = Cell.Offset(0, 1) 'emplacement et body pour les commentaires ou sujets
.body = "N° : " & Cell.Offset(0, 0) _
& vbCrLf _
...
.Save
End With
Set MyItem = Nothing
Else 'si il y a deja un RDV alors message ou continuer avec la date suivante. Au choix
'MsgBox "Un Rdv a déja été inscrit avec cette date:" & vbCrLf & _
OutlAppointment.Subject
Next Cell 'on continue dans l'extraction de donnée
End If
Else: Cell = "" 'si la plage de donnée est vide on quitte le macro
Exit Sub
End If
Next Cell 'tant que les cellules de la plage est complete on relance le macro
End Sub
