Réaliser un système d'envoi de documents individuels avec Access

Private Sub CmdEnvoyerDocuments_Click()

    Me.Refresh ' enregistre les changements effectués sur le formulaire
    If EnvoiDocuments() Then ' si l'envoi s'est bien passé
        Me.Refresh ' on rafraîchit le formulaire
    End If
End Sub

Function EnvoiEmail(cheminfichier As String, EMail As String, ObjetMessage As String, CorpsMessage As String, objOutLook As Object) As Boolean

    'On Error GoTo Erreur_EnvoiEMail
    Dim objMessage As Object ' Outlook.MailItem ' variable objet pour faire référence au mail
        
    Set objMessage = objOutLook.createitem(0) ' création de l'objet Outlook.MailItem
    
    With objMessage
        .To = EMail ' on copie l'adresse mail du destinataire
        .Subject = ObjetMessage ' on copie l'objet du message
        'Corps du message
        .BodyFormat = 3 'olFormatRichText : on définit le format Texte enrichi
        .HTMLBody = CorpsMessage ' on copie le message

        If (cheminfichier <> "") Then ' si un chemin de fichier est passé en argument
            objMessage.Attachments.Add cheminfichier ' on attache le fichier au mail
        End If
        
        .Send ' envoi de l'e-mail
         EnvoiEmail = True ' on indique que tout s'est bien passé
        
    End With
        
    'On libère la mémoire
    Set objMessage = Nothing
    
    ' on sort de la fonction
    Exit Function
    
Erreur_EnvoiEmail:
    ' Gestion de l'erreur
    Select Case Err.Number
    
        Case -2147467259  ' adresse invalide
            MsgBox "Adresse e-mail invalide"
    
        Case 2501
        MsgBox Err.Number & " " & Err.Description
    End Select
    ' si le message n'a pas été envoyé, on le signale en renvoyant une chaîne vide
     EnvoiEmail = False
End Function

call EnvoiDocuments(true)

    Set rsReabo = db.OpenRecordset("select * from R_Echeances_Abonnements where (Envoi=False) and nz(Email,"""")<>"""";", dbOpenDynaset)

DoCmd.OutputTo acOutputReport, "E_Reabonnement", "PDF", cheminfichier

If EnvoiEmail(cheminfichier, rs!email, ObjetMessage, CorpsMessage, objOutLook) Then

Public Function EnvoiDocuments(Optional Automatique As Boolean = False) As Boolean
    'Automatique : argument optionnel indiquant si la fonction s'exécute automatiquement ou pas.
    On Error GoTo err_EnvoiDocuments
    Dim fso As Object ' variable objet FSO
    Dim nomDossier As String ' variable pour le nom du dossier de sauvegarde des documents pdf
    Dim cheminfichier As String ' variable pour le chemin complet du document pdf
    Dim NomAbonne As String ' nom de l'abonné
    Dim db As DAO.Database ' variable objet pour faire référence à la base de données
    Dim rsMsg As DAO.Recordset ' variable objet pour faire référence au recordset lié au message à envoyer
    Dim rsReabo As DAO.Recordset ' variable objet pour faire référence au recordset lié aux réabonnements
    Dim objOutLook As Object ' variable objet pour faire référence à l'application Outlook
    
    Set db = CurrentDb ' référence à la base de données courante
    
    ' on ouvre le recordset basé sur la table T_Message_Reabonnement
    Set rsMsg = db.OpenRecordset("T_Message_Reabonnement", dbOpenSnapshot)
    
    ' on vérifie si l'objet et le corps du message ont été saisis
    If Nz(rsMsg!ObjetMessage) = "" Then
        MsgBox ("Saisir un objet pour le message des destinataires !")
        Exit Function
    End If
    
    If Nz(rsMsg!CorpsMessage) = "" Then
        MsgBox ("Saisir un message pour les destinataires !")
        Exit Function
    End If
    
    ' on ouvre le recordset contenant la liste des réabonnement en attente n'ayant pas encore fait l'objet d'un envoi
    Set rsReabo = db.OpenRecordset("select * from R_Echeances_Abonnements where (Envoi=False) and nz(Email,"""")<>"""";", dbOpenDynaset)
    
    If Not rsReabo.EOF Then ' s'il y a des documents à envoyer
    
        If MsgBox("Souhaitez-vous envoyer les documents pour les réabonnements ?", vbYesNo + vbQuestion) = vbYes Then ' si on confirme l'envoi
        
            ' Teste si outlook est ouvert, si pas ouvert le lance :
            If Not IsOutLookRunning() Then
                Dim oShell As Object
                Set oShell = CreateObject("WScript.Shell")
                oShell.Run "outlook"
                Set oShell = Nothing
            End If
        
            'Assigner l'objet Outlook
            Set objOutLook = CreateObject("Outlook.Application") 'New Outlook.Application
            
            ' création de l'objet FSO
            Set fso = CreateObject("Scripting.FileSystemObject")
            
            ' indique le chemin du dossier de destination pour les fichiers générés, si pas de dossier d'enregistré dans la table T_Dossier_Documents,
            ' alors copie le chemin du dossier situé dans le répertoire de la base de données Access
            nomDossier = Nz(DLookup("CheminDossier", "T_Dossier_Documents"), CurrentProject.Path & "\Réabonnements") ' indiquez ici le chemin de votre dossier de destination pour les fichiers pdf
            
            If Dir(nomDossier, vbDirectory) = "" Then  '
                fso.CreateFolder nomDossier
            End If
            
            Do Until rsReabo.EOF  ' on parcourt la liste des abonnements à renouveler
            
                NomAbonne = rsReabo!NomAbonne & " " & rsReabo!PrenomAbonne ' on copie le nom complet de l'abonné dans la variable
                
                ' on copie le chemin complet dans la variable
                cheminfichier = nomDossier & "\Réabonnement " & NomAbonne & ".pdf"
                
                ' ouverture de l'état filtré avec l'identifiant de l'abonné
                DoCmd.OpenReport "E_Reabonnement", acViewPreview, , "IdAbonne=" & rsReabo!IdAbonne
                
                ' génération du document pdf à partir de l'état filtré avec l'identifiant de l'abonné
                DoCmd.OutputTo acOutputReport, "E_Reabonnement", "PDF", cheminfichier
                
                ' fermeture de l'état
                DoCmd.Close acReport, "E_Reabonnement"
                
                ' envoi du message au destinataire
                If EnvoiEmail(cheminfichier, rsReabo!EMail, rsMsg!ObjetMessage, rsMsg!CorpsMessage, objOutLook) Then ' si l'envoi du mail s'est bien passé
                    rsReabo.Edit
                    rsReabo!DateEnvoiReabo = Date ' on met à jour le champ DateEnvoiReabo pour indiquer que l'envoi a bien été effectué
                    rsReabo.Update
                End If
                
                ' on passe à l'enregistrement suivant
                rsReabo.MoveNext
               
            Loop
            
            EnvoiDocuments = True ' on indique que les documents ont été envoyés
            MsgBox "Documents envoyés !", vbExclamation ' on affiche un message pour indiquer que les documents ont bien été envoyés
        
        End If
        
    Else ' sinon, si pas de document à envoyer
        
        If Not Automatique Then ' si la fonction ne s'exécute pas à l'ouverture de la base
            MsgBox "Pas de document à envoyer pour les réabonnements !", vbExclamation ' on affiche un message pour indiquer qu'il n'y a pas d'abonnement à renouveler
        End If
        
        EnvoiDocuments = False ' la fonction renvoie False
    
    End If
       
err_EnvoiDocuments:
    
    ' gestion d'erreur
    If Err.Number <> 0 And Not EnvoiDocuments Then ' si une erreur s'est produite et que les documents n'ont pas été envoyés
        MsgBox Err.Description, vbExclamation ' on affiche le message d'erreur
        MsgBox "Erreur au cours de l'envoi !", vbExclamation
        EnvoiDocuments = False
    End If
    
    ' libère les variables objet
    Set fso = Nothing
    
    If Not (rsMsg Is Nothing) Then
        rsMsg.Close
    End If
    
    If Not (rsReabo Is Nothing) Then
        rsReabo.Close
    End If
    
    Set rsMsg = Nothing
    Set rsReabo = Nothing
    
    Set db = Nothing
    Set objOutLook = Nothing
    
End Function