1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59
| Sub test()
Dim R As Range
Dim L As Long
Dim msg As String
msg = ""
Set R = ActiveSheet.UsedRange
For L = 4 To R.Rows.Count
If DateValide(R(L, 7), Date, 6) = False Then
R(L, 8) = "A RENOUVELER"
msg = msg & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 7), "LIVRET MARITIME")
End If
If DateValide(R(L, 10), Date, 6) = False Then
R(L, 11) = "A RENOUVELER"
msg = msg & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 10), "PASSPORT")
End If
If DateValide(R(L, 15), Date, 3) = False Then
R(L, 15).Select
R(L, 16) = "A RENOUVELER"
msg = msg & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 15), "VISITE MEDICALE")
End If
Next
If Trim("" & msg) <> "" Then
msg = "<table border='1' cellspacing='0' width='100%'>" & MessageTitre & msg & "</Table>"
Mail "Voici", msg, "ton@maiL.com"
End If
End Sub
Function DateValide(Fin As Date, JJ As Date, Intervale As Integer) As Boolean
If DateDiff("m", Fin, JJ) > Intervale Then DateValide = True
End Function
Sub Mail(Sujet As String, Message As String, Destinataire As String)
Set Outlook = CreateObject("Outlook.application")
Set MailObj = Outlook.CreateItem(olMailItem)
With MailObj
.To = Destinataire
.Subject = Sujet
.BodyFormat = 2
.HTMLBody = Message
'.Display 'Can be .Send but prompts for user intervention before sending without 3rd party software like ClickYes
.Send
End With
End Sub
Function Message(NOM As String, PRENOM As String, FONCTION As String, DATE_EXPIRATION As Date, TypeDoc As String) As String
Message = "<TR>"
Message = Message & "<TD>Le: " & TypeDoc & "</TD>"
Message = Message & "<TD> De: " & NOM & " " & PRENOM & "</TD>"
Message = Message & "<TD>Occupent la fonction de: " & FONCTION & "</TD>"
Message = Message & "<TD>Expire-le : " & DATE_EXPIRATION & "</TD>"
Message = Message & "</TR>" & vbCrLf
End Function
Function MessageTitre() As String
MessageTitre = "<TR>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'> Type de document</TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>  NOM PRENOM </TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>  FONCTION </TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>  DATE EXPIRATION </TD>"
MessageTitre = MessageTitre & "</TR>" & vbCrLf
End Function |
Partager