' Ajouter un nouveau rendez-vous' Si la date de fin de contrat est renseignée
' Si la date de fin de contrat en colonne H est postérieur à la date du jour
' Si cela n'a pas déjà été fait => noté en colonne I
Sub RappelOutlook()
' Il est nécessaire de définir la référence : Microsoft Outlook 1X.0 Library
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Dim Sht As Worksheet
Dim DLig As Long, Lig As Long, Sujet As String, Détail As String
Dim sDate As String, Heure As String, HTemp As String
Dim Delai As Integer, NbMois As Integer, Rappel As Single
' Récupérer les paramètres pour OUTLOOK
Heure = Format(VParam("OutlookHeureR"), "hh:mm:ss") ' Heure de rappel
Rappel = VParam("OutlookRappel") ' Prévenir avant l'heure de
Delai = VParam("OutlookDélaiRDV") ' Délai du RDV en minutes
NbMois = VParam("MoisAvantEcheance") ' Prévenir X mois avant échéance
' Demander l'heure de rappel au cas ou
HTemp = InputBox("A qu'elle heure voulez-vous faire le rappel (HH:MM) ?", "HEURE de RAPPEL ...", Heure)
If HTemp <> "" And HTemp <> Heure Then
If InStr(1, HTemp, ":") > 0 Then Heure = Format(HTemp, "hh:mm:ss")
End If
' Définir la feuille source
Set Sht = Sheets("Frais")
' Récupérer la dernière ligne du tableau
DLig = Sht.Range("A" & Rows.Count).End(xlUp).Row
' Créer l'instance OUTLOOK
Set OutObj = CreateObject("outlook.application")
' Pour chaque ligne sur la feuille
For Lig = 2 To DLig
' Vérifier que le rappel n'a pas déjà été fait, sinon ligne suivante
If Sht.Range("I" & Lig).Value <> "" Then GoTo LigneSuivante
' Récupérer la date de fin de contrat
sDate = Sht.Range("H" & Lig).Value
' Vérifier si aucune date, on passe à la ligne suivante
If sDate = "" Then GoTo LigneSuivante
' Vérifier que la date de fin de contrat est postérieur à la date du jour
' Sinon ligne suivante
If CDate(sDate) < Date Then GoTo LigneSuivante
'
' Tout est OK, on inscrit en colonne I le terme : Fait
Sht.Range("I" & Lig).Value = "Fait"
'
' Formater la date correctement
sDate = Format(CDate(sDate) - (NbMois * 30.417), "dd/mm/yyyy")
' Créer le sujet du mail
Sujet = "Rappel pour la société : " & Sht.Range("A" & Lig).Value & " - Installation : " & Sht.Range("C" & Lig).Value
' Créer l'instance pour le RDV
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
' Si tout est OK, on créé un RDV
With OutAppt
.Start = sDate & " " & Heure
.Duration = Delai
.Location = "Bureau"
.ReminderMinutesBeforeStart = Rappel * 60 ' rappeler 8 heure avant
.ReminderSet = True
.Subject = Sujet
.Body = Détail
'.MeetingStatus = olMeeting
'.OptionalAttendees = "titi@adm.co.ma" 'participants optionnel à la réunion
' Participant(s) obligatoire(s)
'.RequiredAttendees = "DestOutlook"
'.Send
.Save
End With
' Effacer la variable objet des RDV pour le prochain
Set OutAppt = Nothing
' On continue
LigneSuivante:
Next Lig
' Libérez la variable objet Outlook.
Set OutObj = Nothing
' Petit message
MsgBox "Le(s) Rendez-vous à/ont bien été ajouté ! ", vbInformation, "OK ..."
End Sub