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 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
| Sub test()
Dim R As Range
Dim L As Long
Dim msgLIVRET As String
Dim msgPASSPORT As String
Dim msgVISITE As String
msgLIVRET = ""
msgPASSPORT = ""
msgVISITE = ""
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"
msgLIVRET = msgLIVRET & 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"
msgmsgPASSPORT = msgmsgPASSPORT & 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"
msgVISITE = msgVISITE & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 15), "VISITE MEDICALE")
End If
Next
If Trim("" & msgLIVRET) <> "" Then
msgLIVRET = "<table border='1' cellspacing='0' width='100%'>" & MessageTitre & msgLIVRET & "</Table>"
Mail "LIVRET MARITIME", msgLIVRET, "ton@maiL.com"
End If
If Trim("" & msgPASSPORT) <> "" Then
msgPASSPORT = "<table border='1' cellspacing='0' width='100%'>" & MessageTitre & msgPASSPORT & "</Table>"
Mail "PASSPORT", msgPASSPORT, "ton@maiL.com"
End If
If Trim("" & msgVISITE) <> "" Then
msgVISITE = "<table border='1' cellspacing='0' width='100%'>" & MessageTitre & msgVISITE & "</Table>"
Mail ""VISITE MEDICALE", msgVISITE, "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