Re : Forme conditionnelle sur date et alerte sur outlook
Bonjour le forum,
ceci semble fonctionner, envoyé par mail Outlook et/ou en demande de réunion dans Outlook aussi
P.
Sub AlerterMail()
Dim contrat As String
Dim Datefin As String
For Each c In Range("E2:E" & [E65000].End(xlUp).Row)
rouge = c.Value - 15 <= Now And Now <= c.Value + 5
contrat = c.Offset(0, -4) & " " & c.Offset(0, -3).Value
Datefin = c.Value
If rouge Then
Call Rappel(contrat, Datefin) ' rappel en réunion
Call Mail2(contrat, Datefin) ' ou envoi par mail
End If
Next
End Sub
Sub Rappel(contrat, fin)
Dim objOL 'As Outlook.Application
Dim objAppt 'As Outlook.AppointmentItem
Const olAppointmentItem = 1
Const olMeeting = 1
Set objOL = CreateObject("Outlook.Application")
Set objAppt = objOL.createitem(olMeeting) 'olAppointmentItem
With objAppt
.Subject = contrat
.Start = Now + 1
.End = DateAdd("h", 0.5, .Start)
'.Location = "lieu de la réunion"
.body = "La personne " & contrat & " " & " a fini le " & fin
.BusyStatus = olFree
.Categories = ""
.ReminderSet = True
.ReminderMinutesBeforeStart = 15 ' rappel 2 heures avant
.ReminderOverrideDefault = True
.ReminderPlaySound = True 'réveil en fanfare
.Importance = olImportanceHigh
' make it a meeting request
.MeetingStatus = olMeeting
'.OptionalAttendees = "titi@adm.co.ma" 'participants optionnel à la réunion
'.RequiredAttendees = "tata@adm.co.ma;toto@adm.co.ma" 'participant obligatoire
.Send
End With
Set objAppt = Nothing
Set objOL = Nothing
End Sub
Sub Mail2(contrat, fin)
Dim MonOutlook, MonMessage As Object
Dim Corps As String
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.createitem(0)
MonMessage.to = "tamessagerie@hotmail.com"
MonMessage.Subject = "Fin de contrat pour: " & contrat
Corps = "Rappel :" & Chr(13) & Chr(13) & "le contrat de " & contrat & " se termine le " & fin
MonMessage.body = Corps
MonMessage.Send
Set Raccourci = Nothing
Set MonOutlook = Nothing
End Sub