Option Explicit
Const olAppointmentItem As Integer = 1
Const olMeeting As Integer = 1
' Ajouter un nouveau rendez-vous.
Sub RappelOutlook()
Dim OutObj As Object, OutAppt As Object
Dim Lig As Long, Sujet As String, Détail As String
Dim Vdate As String, Heure As String, HTemp As String
Dim Delai As Double, Rappel As Single, sTmp As String
' Ligne sélectionnée sur la feuille
Lig = Selection.Row
' En cas d'erreur
On Error Resume Next
' Vérifier si un commentaire est déjà dans la cellule
If Range("D" & Lig).Comment.Text <> "" Then
If Err.Number = 0 Then
MsgBox "Un RDV à déjà été inscrit, merci de le supprimer dans Outlook", vbInformation, "ATTENTION ...."
Exit Sub
End If
End If
' Réactiver les erreurs
On Error GoTo 0
' Récupérer les paramètres pour OUTLOOK
Delai = Range("F" & Lig).Value * 60 * 24
Rappel = 24 ' 24h avant
Sujet = "Rappel pour : " & Range("H" & Lig).Value & "-" & Range("C" & Lig).Value
Vdate = Range("D" & Lig).Value
If Vdate = "" Then
MsgBox "Vous devez inscrire un date !", vbCritical, "ATTENTION ..."
Range("D" & Lig).Select
Exit Sub
End If
On Error Resume Next
' Heure de rappel
Heure = Range("E" & Lig).Text
' En cas d'erreur
On Error GoTo 0
' Créer l'instance OUTLOOK
Set OutObj = CreateObject("outlook.application")
' Créer l'instance pour le RDV
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
' Si tout est OK, on créé un RDV
With OutAppt
.Start = Vdate & " " & Heure
.Duration = Delai
.Location = Range("C" & Lig).Value
.ReminderMinutesBeforeStart = Rappel * 60 ' rappeler 8 heure avant
.ReminderSet = True
.Subject = Sujet
.Body = Range("G" & Lig).Value
'.MeetingStatus = olMeeting
'.OptionalAttendees = "titi@adm.co.ma" 'participants optionnel à la réunion
' Participant(s) obligatoire(s)
'.RequiredAttendees = "DestOutlook"
'.Send
.Save
End With
' En cas d'erreur on continue
On Error Resume Next
' Inscrire le commentaire dans la cellule
With Range("D" & Lig)
.ClearComments
.AddComment Text:=Sujet
.Comment.Visible = False
End With
' Gestion des erreurs
On Error GoTo 0
' Libérez la variable objet Outlook.
Set OutObj = Nothing
Set OutAppt = Nothing
' Petit message
MsgBox "Le Rendez-vous à bien été ajouté ! ", vbInformation, "OK ..."
End Sub