[VBA] Emails Outlook depuis BDD Excel

Option Explicit
'

Sub RechercheEnvoie()

    Dim Aujourdhui As Date, JourDeadLine As Date
    Dim MoisPrecedent As Date, SemainePrecedente As Date, JourJ As Date
    Dim Feuille As Worksheet, Limite As Long, Boucle As Long
    Dim Adresse As String, Message As String
    
    Aujourdhui = Date
    
    JourJ = Aujourdhui
    SemainePrecedente = DateAdd("ww", -1, Aujourdhui)
    MoisPrecedent = DateAdd("m", -1, Aujourdhui)
    
    Set Feuille = ActiveSheet ' Sheets("Feuil1")
    Limite = Feuille.Range("A65536").End(xlUp).Row
    
    For Boucle = 2 To Limite
        JourDeadLine = Feuille.Cells(Boucle, 4).Value
        Adresse = Feuille.Cells(Boucle, 3).Value
        If (JourDeadLine = MoisPrecedent) Then
            Message = "À un mois du DeadLine"
            Call EnvoieCourriel(Adresse, Message)
        ElseIf (JourDeadLine = SemainePrecedente) Then
            Message = "À une semaine du DeadLine"
            Call EnvoieCourriel(Adresse, Message)
        ElseIf (JourDeadLine = JourJ) Then
            Message = "Aujourdhui c'est le DeadLine"
            Call EnvoieCourriel(Adresse, Message)
        End If
    Next Boucle

End Sub
'

Sub EnvoieCourriel(ByVal Adresse As String, Message As String)

    ' Déclaration de variables
    Dim objApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim sDestination As String, msgTitre As String, msgTexte As String
    
    Set objApp = CreateObject("Outlook.Application")
    Set objMail = objApp.CreateItem(olMailItem)
    
    sDestination = Adresse
    msgTitre = "Avis de DeadLine"
    msgTexte = Message
    
    With objMail
        .To = sDestination
        .Subject = msgTitre
        .BodyFormat = olFormatPlain
        .Body = msgTexte
        .Send
    End With
    
    Set objMail = Nothing
    Set objApp = Nothing

End Sub
'