Envoyer une feuille Excel par mail avec macro

Le 25/10/2019 à 16:33

Bonjour à toutes et à tous,

Voilà j'aimerais facilité la gestion de mon association, et surtout pour l'envoie de document personnaliser à chaque membre.

Je m'explique :

J'ai une feuille excel ou dessus j'ai crée une carte membre pour pouvoir bénéficier d'avantage chez nos partenaire.

Mais j'ai réussi à l'enregistré en PDF avec un nom différent selon le membre choisi.

Mais la ou je sèche c'est que j'aimerais pouvoir envoyer ce PDF directement depuis excel avec une macro en ajoutant un texte basic pour tous les envoies.

Mille Merci pour votre aide.

Ps : dsl si je me suis trompé de lieu pour mon poste je suis nouveau ici.

35dossier-membres-pp71-teste.xlsm (487.78 Ko)
Le 25/10/2019 à 21:14

Bonjour gaykoina,

vois si ça te convient:

Sub PDFandMail()

    Dim WsCM   As Worksheet
    Dim inputRange As Range, cel    As Range, DropDown As Range
    Dim i      As Long
    Dim Chemin As String, Fichier As String, Destinataire As String, Contenu As String
    Dim MaMessagerie As Object, MonMessage As Object

    Set WsCM = Sheets("Carte Membre")
    Set DropDown = WsCM.Range("I8")
    Set inputRange = Evaluate(DropDown.Validation.Formula1)

    Chemin = "C:\Users\gayko\Desktop\Pese Plume 71\ADMINISTRATION\Membres\Cartes\A envoyer\"

    Application.ScreenUpdating = False

    For Each cel In inputRange
        On Error Resume Next

        DropDown = cel.Value

        Fichier = Chemin & DropDown & ".pdf"
        Destinataire = WsCM.Range("Q15")
        Contenu = "Bonjour," & vbNewLine & _
                  "Voici ta carte Membre de l'Association Pèse-Plume 71, pour l'année 2019-2020." & vbNewLine & _
                  "Cette carte est dématérialisé donc il faut la garder. Ps : Merci de signaler tout changement de coordonnées."

        WsCM.ExportAsFixedFormat _
                                 Type:=xlTypePDF, _
                                 Filename:=Fichier, _
                                 Quality:=xlQualityStandard, _
                                 IncludeDocProperties:=True, _
                                 IgnorePrintAreas:=False, _
                                 OpenAfterPublish:=False

        Set MaMessagerie = CreateObject("Outlook.Application")
        Set MonMessage = MaMessagerie.CreateItem(0)

        With MonMessage
            .To = Destinataire
            .Subject = "Envoie Carte Membre de l'Association Pèse-Plume 71"
            .body = Contenu
            .Attachments.Add Fichier
            .Display
        End With

        Kill Fichier

        i = i + 1
    Next cel

    Application.ScreenUpdating = True

End Sub
Le 25/10/2019 à 23:24

Bonjour Sequoyah,

Sa marche mais c'est pas encore cela,

La il me fait le premier mail avec la bonne pièces jointe et après il continue avec les autres mails et il rajoute tous les pièces jointes sur chaque mail.

Or Moi je ne veut qu'il ne crée qu'un seul mail avec la pièce jointe associer.

Le 26/10/2019 à 20:10

Bonjour gaykoina et merci pour ton retour ,

en effet ma macro ne fonctionne pas avec la version Excel 2013. Je te propose une solution différente basée sur le publipostage, voir fichier joint et ci-dessous le code (Module3):

Sub PDFandMail2()
    'https://forum.excel-pratique.com/viewtopic.php?f=2&t=131404

    Dim WsCarte   As Worksheet, WsMember As Worksheet
    Dim LastRow As Long
    Dim cel    As Range
    Dim i      As Long
    Dim Member As String, Chemin As String, Fichier As String, Destinataire As String, Contenu As String
    Dim Nom    As String, Prenom As String, Adresse As String, CPVille As String

    Dim MaMessagerie As Object, MonMessage As Object

    Set WsMember = Sheets("Membres_A")
    Set WsCarte = Sheets("Carte Membre")

    LastRow = WsMember.Range("A" & Rows.Count).End(xlUp).Row

    Chemin = "C:\Users\gayko\Desktop\Pese Plume 71\ADMINISTRATION\Membres\Cartes\A envoyer\"

    Application.ScreenUpdating = False

    For Each cel In WsMember.Range("A2:A" & LastRow)
        On Error Resume Next

        Member = cel.Value
        Nom = cel.Offset(0, 2).Value
        Prenom = cel.Offset(0, 3).Value
        Adresse = cel.Offset(0, 4).Value
        CPVille = cel.Offset(0, 5).Value & " " & cel.Offset(0, 6).Value
        Destinataire = cel.Offset(0, 9).Value

        WsCarte.Range("I8").Value = Member
        WsCarte.Range("I9").Value = Nom
        WsCarte.Range("I10").Value = Prenom
        WsCarte.Range("H11").Value = Adresse
        WsCarte.Range("I12").Value = CPVille

        Fichier = Chemin & Member & ".pdf"

        Contenu = "Bonjour," & vbNewLine & _
        "Voici ta carte Membre de l'Association Pèse-Plume 71, pour l'année 2019-2020." & vbNewLine & _
        "Cette carte est dématérialisé donc il faut la garder. Ps : Merci de signaler tout changement de coordonnées."

        WsCarte.ExportAsFixedFormat _
                                    Type:=xlTypePDF, _
                                    Filename:=Fichier, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False

        Set MaMessagerie = CreateObject("Outlook.Application")
        Set MonMessage = MaMessagerie.CreateItem(0)

        With MonMessage
            .To = Destinataire
            .Subject = "Envoie Carte Membre de l'Association Pèse-Plume 71"
            .body = Contenu
            .Attachments.Add Fichier
            .Display
        End With

        Kill Fichier

        i = i + 1
    Next cel

    Application.ScreenUpdating = True

End Sub
24dossier-membres-pp71-teste2.xlsm (494.23 Ko)
Le 27/10/2019 à 20:16

Bonjour gaykoina,

le problème dans ton premier fichier est probablement causé par la plage nommée TEST qui comprend aussi des cellules vides. Essaye de changer la formule

=Membres_A!$A$2:$A$200

par

=DECALER(Membres_A!$A$2; 0; 0; NBVAL(Membres_A!$A:$A)-1;1) pour créer une plage définie dynamique qui s'ajuste automatiquement lorsque on entre de nouvelles valeurs dans la colonne A.

Le 31/10/2019 à 13:46

Bonjour Sequoyah,

Merci pour ton aide mais cela continue a envoyer tous les fichiers a partir du membre 3 le 1 et le 2 c'est ok apres sa bloque et ajoute toutes les fiches au même contacte.

bug envoie
Le 31/10/2019 à 19:16

Bonjour gaykoina,

as-tu essayé les deux solutions que je t’ai proposées? J'ai testé la macro avec la version Excel 2013 sans problème.

Dans mon code à chaque exécution de la boucle la commande Kill Fichier supprime le fichier PDF après l'avoir joint au message, donc il ne devrait pas y avoir de fichier dans le dossier. Tu peux essayer de relancer la macro en changeant le chemin, par exemple

Chemin = "C:\Users\gayko\Desktop\"

Le 03/11/2019 à 11:31

Bonjour Sequoyah,

Je reviens vers toi car cela ne change rien sa fonctionne pour les 2 ou 3 premier et paf sa bloque.

Sa ajoute tout les fichiers sur la même adresse mail.

Et de plus sa me modifie mon fichier carte membres ou dessus j'ai un un concatener et des rechercheV, sur les cellules i09, I10, I11, I12.

Moi ce que je voudrais c'est que sa envoie juste le fichier au contacte choisi.

Encore merci pour ta grande aide.

Je touche au but et ceux en grande partie grasse à toi.

Le 03/11/2019 à 17:42

Bonjour gaykoina,

peux-tu joindre une copie de la dernière version du fichier que tu utilises (après avoir supprimé toutes les données personnelles dans l'onglet Membres_A)?

Le 03/11/2019 à 19:27

Bonjour Sequoyah,

Voici le fichier.

Merci beaucoup encore.

5test-03-11-2019.xlsm (501.19 Ko)
Le 03/11/2019 à 21:21

Bonjour gaykoina,

je n'arrive pas à répliquer le problème, ici ça marche sans aucun souci. Je vais essayer demain sur un PC différent avec la version excel 2013. J’ai trouvé deux imprécisions dans le code mais ils ne devraient pas être la cause du problème, on doit effacer la ligne

destinataires = Q15

et la ligne

i = i + 1

Une nouvelle question, que faut-il faire pour les membres qui n'ont pas de mail? Si on ne veut pas générer un message dans ce cas, on peut ajouter deux lignes de code.

Après la ligne

For Each cel In WsMember.Range("A2:A" & LastRow)

ajouter:

If cel.Offset(0, 9).Value <> "" Then

pour envoyer le mail si l'adresse n'est pas vide.

et

End if

avant la ligne

Next cel
Le 06/11/2019 à 11:05

Bonjour Sequoyah,

On avance énormément mais sa coince encore à deux trois endroits encore.

Moi je voudrais que sa envoie le mail à uniquement la personne que je sélectionne en I8 avec sont mail associer en Q15.

Et surtout que sa ne modifie pas mon doc de base "Carte Membre", car actuellement les mails sont quasiment unique (la bonne pièce au bon mail), mais sa efface encore les formules en I9, I10, I11, I12.

Vraiment merci de ton aide précieuse.

Le 06/11/2019 à 19:22

Bonjour gaykoina,

une nouvelle tentative, voir le fichier joint et ci-dessous le code pour l'envoi des messages un à la fois:

Sub CommandButton3_Click()

    Dim WsCarte     As Worksheet

    Dim Member      As String, Chemin As String, Fichier As String, Destinataire As String, Contenu As String
    Dim Nom         As String, Prenom As String, Adresse As String, CPVille As String

    Dim MaMessagerie As Object, MonMessage As Object

    Set WsCarte = Sheets("Carte Membre")

    Chemin = "C:\Users\gayko\Desktop\Pese Plume 71\ADMINISTRATION\Membres\Cartes\A envoyer\"

    Application.ScreenUpdating = FALSE

    Member = WsCarte.Range("I8").Value
    Nom = WsCarte.Range("I9").Value
    Prenom = WsCarte.Range("I10").Value
    Adresse = WsCarte.Range("H11").Value
    CPVille = WsCarte.Range("I12").Value
    Destinataire = WsCarte.Range("Q15").Value

    Fichier = Chemin & Member & ".PDF"

    Contenu = "Bonjour " & Prenom & "," & vbNewLine & _
              vbNewLine & _
              "Voici ta carte Membre de        'Association Pèse-Plume 71, pour l'année 2019-2020." & vbNewLine & _
              "Cette carte est dématérialisé donc il faut la garder. " & vbNewLine & _
              "Ps : Merci de signaler tout changement de coordonnées." & vbNewLine & _
              vbNewLine & _
              vbNewLine & _
              "Bien Cordialement," & vbNewLine & _
              "Mr.Aurélien GOUSSARD" & vbNewLine & _
              "Le Président de Pèse-Plume 71" & vbNewLine & _
              "Association Loi 1901," & vbNewLine & _
              "Maison des Association" & vbNewLine & _
              "Espace Jean - Zay" & vbNewLine & _
              "4, Rue Jules Ferry" & vbNewLine & _
              "71 100 Chalon Sur Saône" & vbNewLine & _
              "07.81.13.01.93." & vbNewLine & _
              "peseplume71@ gmail.com" _

    WsCarte.ExportAsFixedFormat _
              Type:=xlTypePDF, _
              Filename:=Fichier, _
              Quality:=xlQualityStandard, _
              IncludeDocProperties:=True, _
              IgnorePrintAreas:=False, _
              OpenAfterPublish:=False

    Set MaMessagerie = CreateObject("Outlook.Application")
    Set MonMessage = MaMessagerie.CreateItem(0)

    With MonMessage
        .To = Destinataire
        .Subject = "Envoie Carte Membre de        'Association Pèse-Plume 71"
        .Body = Contenu
        .Attachments.Add Fichier
        .Display
    End With

    Kill Fichier

    Application.ScreenUpdating = TRUE
End Sub
20test-06-11-2019.xlsm (495.75 Ko)
Le 08/11/2019 à 22:28

Bonjour Sequoyah,

Je tenais à te remercier énormément pour ta superbe aide car mon fichier et fini.

Et Je te remercie infiniment.

Le Président de L'Association Pèse-Plume 71.

Le 21/11/2019 à 12:31

Bonjour Sequoyah,

Je reviens vers toi pour savoir s'il etait possible de changer l'application Outlook par l'application Courrier de Windows 10, car nous n'avons pas de licence pour office 365.

Merci encore. sinon VBA fonctionne au top.

Le 21/11/2019 à 21:25

Bonjour gaykoina,

on ne peut pas utiliser l'application Courrier de Windows 10 mais tu peux passer en direct par CDO (Collaboration Data Objects), voici le code, il faut adapter tous les paramètres relatifs à ton compte de messagerie:

Sub CommandButton3_Click()

    Dim WsCarte     As Worksheet

    Dim Member      As String, Chemin As String, Fichier As String, Destinataire As String, Contenu As String
    Dim Nom         As String, Prenom As String, Adresse As String, CPVille As String

    Dim iMsg As Object, iConf As Object

    Set WsCarte = Sheets("Carte Membre")

    Chemin = "C:\Users\gayko\Desktop\Pese Plume 71\ADMINISTRATION\Membres\Cartes\A envoyer\"

    Application.ScreenUpdating = False

    Member = WsCarte.Range("I8").Value
    Nom = WsCarte.Range("I9").Value
    Prenom = WsCarte.Range("I10").Value
    Adresse = WsCarte.Range("H11").Value
    CPVille = WsCarte.Range("I12").Value
    Destinataire = WsCarte.Range("Q15").Value

    Fichier = Chemin & Member & ".PDF"

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.xxxx.fr" '===>> server SMTP à adapter
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 '===>> à adapter

        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username" '===>> à adapter
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password" '===>> à adapter

        .Update
    End With

    Contenu = "Bonjour " & Prenom & "," & vbNewLine & _
              vbNewLine & _
              "Voici ta carte Membre de l'Association Pèse-Plume 71, pour l'année 2019-2020." & vbNewLine & _
              "Cette carte est dématérialisé donc il faut la garder. " & vbNewLine & _
              "Ps : Merci de signaler tout changement de coordonnées." & vbNewLine & _
              vbNewLine & _
              vbNewLine & _
              "Bien Cordialement," & vbNewLine & _
              "Mr.Aurélien GOUSSARD" & vbNewLine & _
              "Le Président de Pèse-Plume 71" & vbNewLine & _
              "Association Loi 1901," & vbNewLine & _
              "Maison des Association" & vbNewLine & _
              "Espace Jean - Zay" & vbNewLine & _
              "4, Rue Jules Ferry" & vbNewLine & _
              "71 100 Chalon Sur Saône" & vbNewLine & _
              "07.81.13.01.93." & vbNewLine & _
              "peseplume71@ gmail.com" _

    WsCarte.ExportAsFixedFormat _
              Type:=xlTypePDF, _
              Filename:=Fichier, _
              Quality:=xlQualityStandard, _
              IncludeDocProperties:=True, _
              IgnorePrintAreas:=False, _
              OpenAfterPublish:=False

    With iMsg
        Set .Configuration = iConf
        .To = Destinataire
        .CC = "monadresse@mail.fr" '===>> répète ton adresse ici sinon tu tu n'auras aucune trace de l'envoi
        .BCC = ""
        .From = """Association Pèse-Plume 71"" <monadresse@mail.fr>" '===>> à adapter
        .Subject = "Envoie Carte Membre de l'Association Pèse-Plume 71"
        .TextBody = Contenu
        .AddAttachment Fichier
        .Send
    End With

    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing

    Kill Fichier

    Application.ScreenUpdating = True
End Sub
Le 22/11/2019 à 08:23

Bonjour Sequoyah,

Pour ton nouveau code il faut avoir une messagerie de paramétré sur le pc en plus de Courrier de Windows 10 ?

Le 22/11/2019 à 21:36

Bonjour gaykoina,

aucun autre logiciel ne doit être configuré, les paramètres doivent être insérés dans le code où indiqué. J’ai vu que tu as un compte gmail, j’ai modifié le code avec les paramètres du serveur gmail, il devrait suffire d'ajouter l'adresse complète et le mot de passe.

Sub CommandButton3_Click()

    Dim WsCarte     As Worksheet

    Dim Member      As String, Chemin As String, Fichier As String, Destinataire As String, Contenu As String
    Dim Nom         As String, Prenom As String, Adresse As String, CPVille As String

    'Dim MaMessagerie As Object, MonMessage As Object
    Dim iMsg As Object, iConf As Object

    Set WsCarte = Sheets("Carte Membre")

    Chemin = "C:\Users\gayko\Desktop\Pese Plume 71\ADMINISTRATION\Membres\Cartes\A envoyer\"

    Application.ScreenUpdating = False

    Member = WsCarte.Range("I8").Value
    Nom = WsCarte.Range("I9").Value
    Prenom = WsCarte.Range("I10").Value
    Adresse = WsCarte.Range("H11").Value
    CPVille = WsCarte.Range("I12").Value
    Destinataire = WsCarte.Range("Q15").Value

    Fichier = Chemin & Member & ".PDF"

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds

    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" 
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 

        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "monadresse@gmail.com" '===>> à adapter
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password" '===>> à adapter

        .Update
    End With

    Contenu = "Bonjour " & Prenom & "," & vbNewLine & _
              vbNewLine & _
              "Voici ta carte Membre de l'Association Pèse-Plume 71, pour l'année 2019-2020." & vbNewLine & _
              "Cette carte est dématérialisé donc il faut la garder. " & vbNewLine & _
              "Ps : Merci de signaler tout changement de coordonnées." & vbNewLine & _
              vbNewLine & _
              vbNewLine & _
              "Bien Cordialement," & vbNewLine & _
              "Mr.Aurélien GOUSSARD" & vbNewLine & _
              "Le Président de Pèse-Plume 71" & vbNewLine & _
              "Association Loi 1901," & vbNewLine & _
              "Maison des Association" & vbNewLine & _
              "Espace Jean - Zay" & vbNewLine & _
              "4, Rue Jules Ferry" & vbNewLine & _
              "71 100 Chalon Sur Saône" & vbNewLine & _
              "07.81.13.01.93." & vbNewLine & _
              "peseplume71@ gmail.com" _

    WsCarte.ExportAsFixedFormat _
              Type:=xlTypePDF, _
              Filename:=Fichier, _
              Quality:=xlQualityStandard, _
              IncludeDocProperties:=True, _
              IgnorePrintAreas:=False, _
              OpenAfterPublish:=False

    With iMsg
        Set .Configuration = iConf
        .To = Destinataire
        .CC = "monadresse@gmail.com" '===>> répète ton adresse ici sinon tu tu n'auras aucune trace de l'envoi
        .BCC = ""
        .From = """Association Pèse-Plume 71"" <monadresse@gmail.com>" '===>> à adapter
        .Subject = "Envoie Carte Membre de l'Association Pèse-Plume 71"
        .TextBody = Contenu
        .AddAttachment Fichier
        .Send
    End With

    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing

    Kill Fichier

    Application.ScreenUpdating = True
End Sub
Le 25/11/2019 à 09:28

Bonjour Sequoyah,

Je vais finir par m'arraché les cheveux avec ce VBA.

J'ai recopier ton Code en remplacent mes info perso (adresse et mot de passe Mail), mais maintenant je reçoit un message d'erreur

capture erreur

Merci de ta très grande aide.

Le 25/11/2019 à 19:51

Bonjour gaykoina,

le message d'erreur affiché peut avoir plusieurs causes (blocage par le logiciel antivirus ou de pare-feu, etc.), c'est presque impossible de mieux comprendre sans accès direct à ton ordinateur. Mon dernier conseil, modifie le paramètre suivant dans ton compte Google -> Sécurité -> Accès moins sécurisé des applications -> Activer l'accès (déconseillé) -> OUI

Rechercher des sujets similaires à "envoyer feuille mail macro"