Envoyer une feuilles du classeur actif en pièce jointe via CDO

**brunohampert** · 09/06/2020, 20h25

Bonjour à toutes et tous,

J'ai créer un fichier avec une feuilles "Recapitulatif" et une feuille "modèle".
Dans le récapitulatif, j'encode les nom et prénom de personne, ensuite je clique sur mon bouton "ajouter feuilles" et les feuilles sont bien créées.
Ensuite j'aimerais envoyer à chaque personne un mail avec sa feuille en pièce jointe.
pour le mail c'est ok mais pour la pièce jointe je coince.
Pourriez-vous m'aider svp?

Merci

Voici mon code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub SendMail_CDO()
Dim J As Long
Dim Ws As Worksheet
Dim Cdo_Message As Object
Dim Signature As String
 
Signature = "Raphaël Paquet" & vbCrLf & "La Ferme de Pâques" & vbCrLf & "Les Fossés"  'changer votre nom entre les " "
 
 
Set Cdo_Message = CreateObject("CDO.Message")
Sheets("Recapitulatif").Select
Set Ws = ActiveSheet
    For J = 2 To Cells(Application.Rows.Count, 2).End(xlUp).Row
        If Cells(J, 2) <> "" Then
 
            With Cdo_Message
                .To = Cells(J, 2)
                .From = "bruno.hampert@gmail.com"
                .Subject = "Récapitulatif " & Ws.Range("C" & J) & " " & Ws.Range("D" & J)
                .TextBody = "Bonjour " & Ws.Range("D" & J) & "," & vbCrLf & vbCrLf & "Ci-joint votre récapitulatif." & vbCrLf & vbCrLf & Signature
                '.AddAttachment = ThisWorkbook.Sheets(Ws.Range("C" & J) & " " & Ws.Range("D" & J)).Copy ' C'est ici que ça coince
                        'nom du serveur smtp
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
                        'port du serveur smtp
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
 
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
                        'S’authentifier
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
 
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
                        'Si autentifié le nom d'utilisateur
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "bruno.hampert@gmail.com"
                        'Si authentifié le mot de passe
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*********"
 
                            .Configuration.Fields.Update
 
                .Send
            End With
        End If
    Next
 
    Set Cdo_Message = Nothing
 
 
End Sub

Gestion paniers vierge(version 1.5).xlsm

Invité · 10/06/2020, 04h50

Envoyé par brunohampert

Bonjour,

Il faut sans doute que votre onglet soit d'abord transformé en fichier sur votre disque dur, puis le récupérer avec son chemin complet dans votre ligne de code.

**brunohampert** · 10/06/2020, 11h07

Bonjour,

Merci de votre réponse.

Je ne vois pas trop comment faire…
De plus, il peut y avoir parfois plus de 100 feuilles

Ca risque de coincer , non ?

Bruno

Invité · 10/06/2020, 12h25

Envoyé par brunohampert

De plus, il peut y avoir parfois plus de 100 feuilles

Envoyer un fichier Excel est une fausse bonne idée, car vos interlocuteurs n'ont pas forcément ce logiciel vue la nature de votre activité. Il est préférable d'exporter votre onglet en pdf d'abord puis de le joindre à votre mail.

**brunohampert** · 10/06/2020, 23h29

Bonjour,

Je créée un pdf pour chaque feuille, et je la sauvegarde dans un répertoire "temp" avec "ActiveWorkbook.path"

J'arrive à envoyer un mail (lorsqu'il y a une adresse mail), mais j'ai un souci,

Le premier mail il y a un fichier, le deuxième mail il y a deux fichiers… et ainsi de suite !

Un coup de main ne serait pas de refus

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
75
76
 
Sub SendMail_CDO()
Dim J As Long
Dim Ws As Worksheet
Dim Cdo_Message As Object
Dim Signature As String
Dim Message As String
Dim Repertoire, Fichier As String
Dim Chemin As String
 
Signature = "Raphaël Paquet" & vbCrLf & "La Ferme de Pâques" & vbCrLf & "Les Fossés"  'changer votre nom entre les " "
 
 
 
Set Cdo_Message = CreateObject("CDO.Message")
Sheets("Recapitulatif").Select
Set Ws = ActiveSheet
Message = InputBox("Entrez le message à placer dans le mail !", "Corps du mail", "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver en pièce jointe votre récapitulatif" & vbCrLf & vbCrLf & Signature)
    For J = 2 To Cells(Application.Rows.Count, 2).End(xlUp).Row
 
 
        MsgBox (Ws.Range("C" & J) & " " & Ws.Range("D" & J) & Date & ".pdf a été sauvegardé dans ce répertoire.")
        If Cells(J, 2) <> "" Then
            ' Création du fichier pdf
            Repertoire = ThisWorkbook.Path & "\temp\" 'répertoire à adapter
            Fichier = Ws.Range("C" & J) & " " & Ws.Range("D" & J) & Format(Date, "DD MMM YYYY") & ".pdf" 'Nom du fichier avec le nom du client
            ThisWorkbook.Sheets(Ws.Range("C" & J) & " " & Ws.Range("D" & J)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            Repertoire & Fichier, Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
 
            With Cdo_Message
                .To = Cells(J, 2)
                .From = "bruno.hampert@gmail.com"
                .Subject = "Récapitulatif " & Ws.Range("C" & J) & " " & Ws.Range("D" & J)
                .TextBody = Message '"Bonjour " & Ws.Range("D" & J) & "," & vbCrLf & vbCrLf & "Ci-joint votre récapitulatif." & vbCrLf & vbCrLf & Signature
                .AddAttachment ActiveWorkbook.Path & "\temp\" & Ws.Range("C" & J) & " " & Ws.Range("D" & J) & Format(Date, "DD MMM YYYY") & ".pdf"
                '.AddAttachment = ThisWorkbook.Sheets(Ws.Range("C" & J) & " " & Ws.Range("D" & J)).Copy ' C'est ici que ça coince
                        'nom du serveur smtp
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
                                    '("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com"
                        'port du serveur smtp
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
                                    '("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 ou '587
 
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
                        'S’authentifier
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
 
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
                        'Si autentifié le nom d'utilisateur
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "bruno.hampert@gmail.com"
                                    '("http://schemas.microsoft.com/cdo/configuration/sendusername") = "PrenomNom@yahoo.fr"
                        'Si authentifié le mot de passe
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "********"
                                    '("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "********"
 
                            .Configuration.Fields.Update
 
                .Send
 
            End With
        End If
    Next
 
    Set Cdo_Message = Nothing
 
 
End Sub

Merci d'avance

Bruno

Invité · 11/06/2020, 03h38

Envoyé par brunohampert

J'ai un peu modifié votre fichier, ajouté une colonne Fichiers pdf et créé un bouton qui génère les pdf et qui mémorise le chemin complet des fichiers générés. Pour l'envoi des mail, il suffit donc d'utiliser ces cellules.

Pièce jointe 572093

Le code pour générer les fichiers pdf :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
 
Sub CreerLesPdfs()
 
Dim J As Long
Dim Ws As Worksheet
Dim RepertoirePdf As String, Fichier As String, NomDeLOnglet As String
 
    RepertoirePdf = ActiveWorkbook.Path & "\Répertoires pdf\"
 
    Set Ws = Sheets("Recapitulatif")
    With Ws
        For J = 11 To .Cells(.Rows.Count, 2).End(xlUp).Row
            If .Cells(J, 2) <> "" And .Cells(J, 3) <> "" And .Cells(J, 5) <> "" And .Cells(J, 7) = "" Then
 
               NomDeLOnglet = .Cells(J, 3) & " " & .Cells(J, 4)  ' Nom prénom
               Fichier = RepertoirePdf & NomDeLOnglet & " " & Format(Date, "DD MMM YYYY") & ".pdf" 'Nom du fichier avec le nom du client
 
               If FeuilleExiste(NomDeLOnglet) Then
                  Sheets(NomDeLOnglet).ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fichier, Quality:= _
                     xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                  .Cells(J, 7) = Fichier
               End If
            End If
        Next J
    End With
    Set Ws = Nothing
 
    MsgBox "Fin de création des fichiers pdf !", vbInformation
 
End Sub
 
Function FeuilleExiste(Nom As String) As Boolean
 
Dim I As Integer
 
  FeuilleExiste = False
  For I = 1 To Sheets.Count
      If Sheets(I).Name = Nom Then
         FeuilleExiste = True
         Exit For
      End If
  Next I
 
End Function

En transformant votre tableau en tableau structuré (nommé TableDesPaniers) comme dans le vidage d'écran, cela donnerait cela :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub CreerLesPdfsV2()
 
Dim J As Long
Dim Ws As Worksheet
Dim RepertoirePdf As String, Fichier As String, NomDeLOnglet As String
Dim AireOnglets As Range
 
    RepertoirePdf = ActiveWorkbook.Path & "\Répertoires pdf\"
    Set AireOnglets = Range("TableDesPaniers").Columns(2).Cells
    For J = 1 To AireOnglets.Count
        With AireOnglets(J)
             If .Value <> "" And .Offset(0, 1) <> "" And .Offset(0, 2) <> "" And .Offset(0, 5) = "" Then
 
                NomDeLOnglet = .Offset(0, 1) & " " & .Offset(0, 2) ' Nom prénom
                Fichier = RepertoirePdf & NomDeLOnglet & " " & Format(Date, "DD MMM YYYY") & ".pdf" 'Nom du fichier avec le nom du client
 
                If FeuilleExiste(NomDeLOnglet) Then
                   Sheets(NomDeLOnglet).ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fichier, Quality:= _
                     xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                   .Offset(0, 5) = Fichier
                End If
             End If
        End With
    Next J
 
    MsgBox "Fin de création des fichiers pdf !", vbInformation
 
End Sub

Et pour la génération des onglets :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
 
Sub Ajouter_Feuilles()
 
Dim DL As Long
Dim J As Long
Dim ShCopie As Worksheet
Dim NomFeuille As String
Dim AireOnglets As Range
 
 
  Application.ScreenUpdating = False
  Set AireOnglets = Range("TableDesPaniers").Columns(2).Cells
  For J = 1 To AireOnglets.Count
      With AireOnglets(J)
 
           NomFeuille = .Offset(0, 1) & " " & .Offset(0, 2)
           If FeuilleExiste(NomFeuille) = False Then
              Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
              Set ShCopie = Sheets(Sheets.Count)
              With ShCopie
                   .Name = NomFeuille
                   .Range("A1") = .Name
              End With
 
              .Offset(0, 3) = "='" & ShCopie.Name & "'!C1"
              .Offset(0, 4).Hyperlinks.Add Anchor:=.Offset(0, 4), Address:="", SubAddress:="='" & ShCopie.Name & "'!A1", TextToDisplay:=ShCopie.Name
 
              Set ShCopie = Nothing
 
           End If
        End With
  Next J
 
  Application.ScreenUpdating = True
 
End Sub

**brunohampert** · 11/06/2020, 23h59

Bonsoir,

Un grand merci pour le travail réalisé et le temps passé.

Dans la création des onglets, il y a une feuille vierge qui s'ajoute en dernier, j'ai donc gardé mon code pour générer les feuilles.
Pour la création des fichiers pdf, pas besoin d'afficher le chemin, puisqu'une fois envoyé le fichier est supprimé.

Par contre, j'ai toujours le souci lors de l'envoie des mails…
Le premier mail = une pièce jointe
le deuxième = deux pièces jointes
le troisième = trois…

Bonne soirée

Bruno

ps: En pièce jointe, la dernière version de mon fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
Sub SendMail_CDO()
Dim J As Long
Dim Ws As Worksheet
Dim Cdo_Message As Object
Dim Message As String
Dim Repertoire, Fichier As String
Dim Chemin As String
 
Set Cdo_Message = CreateObject("CDO.Message")
Sheets("Recapitulatif").Select
Set Ws = ActiveSheet
    Form_Mail.Show
    For J = 2 To Cells(Application.Rows.Count, 2).End(xlUp).Row
        Chemin = ThisWorkbook.Path & "\temp\" & Ws.Range("C" & J) & " " & Ws.Range("D" & J) & " " & Format(Date, "DD MMM YYYY") & ".pdf"
        If Cells(J, 2) <> "" Then
            ' Création du fichier pdf
            Repertoire = ThisWorkbook.Path & "\temp\" 'répertoire à adapter
            Fichier = Ws.Range("C" & J) & " " & Ws.Range("D" & J) & " " & Format(Date, "DD MMM YYYY") & ".pdf" 'Nom du fichier avec le nom du client
            ThisWorkbook.Sheets(Ws.Range("C" & J) & " " & Ws.Range("D" & J)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            Repertoire & Fichier, Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
            MsgBox (Ws.Range("C" & J) & " " & Ws.Range("D" & J) & " " & Format(Date, "DD MMM YYYY") & ".pdf a été sauvegardé dans le répertoire \temp.")
            With Cdo_Message
                .To = Cells(J, 2)
                .From = "bruno.hampert@gmail.com"
                .Subject = "Récapitulatif " & Ws.Range("C" & J) & " " & Ws.Range("D" & J)
                .HTMLBody = "<HTML><body><p>Bonjour,</p>" _
                          & "<p>" & TxtBody1 & "</p>" _
                          & "<br></br>" _
                          & "<p>" & TxtBody2 & "</p>" _
                          & "<br></br>" _
                          & "<p>" & TxtBody3 & "</p>" _
                          & "<br></br>" _
                          & "<br></br>Cordialement.<br></br><br></br>" _
                          & "<p align='center'>Raphaël Paquet</p></body><HTML>" _
                          & "<p align='center'>La Ferme de Pâquest</p></body><HTML>" _
                          & "<p align='center'>Les Fossés</p></body><HTML>" _
                          & "<br></br><br></br><HTML>"
                 .AddAttachment (Chemin)
                        'nom du serveur smtp
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
                                    '("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com"
                        'port du serveur smtp
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
                                    '("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 ou '587
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
                        'S’authentifier
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
                        'Si autentifié le nom d'utilisateur
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "bruno.hampert@gmail.com"
                                    '("http://schemas.microsoft.com/cdo/configuration/sendusername") = "raphaelpaquet@yahoo.fr"
                        'Si authentifié le mot de passe
                            .Configuration.Fields.Item _
                            ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "******"
                                    '("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*******Pièce jointe 572417"
                            .Configuration.Fields.Update
                            .Send
            End With
            Kill Chemin
        End If
    Next
    Set Cdo_Message = Nothing
End Sub

Gestion paniers vierge(version 1.6).xlsm

Invité · 12/06/2020, 06h17

Envoyé par brunohampert

De mon point de vue, il vaut mieux dissocier la création des pdf de leur envoi... Sinon, plutôt qu'instancier et supprimer la variable CDO en dehors de la boucle, faites le à l'intérieur. Dès lors que vous avez défini le contenu de Chemin, Repertoire et Fichier ne servent à rien.

**brunohampert** · 25/06/2020, 19h01

Bonjour,

Désolé d'être rester longtemps sans répondre...

Ça fonctionne mieux lorsque la variable CDO est instanciée et supprimé à l'intérieur de la boucle.

J'ai encore un souci avec ma boucle,
Elle s'arrête à un moment avec le message d'erreur.

"Erreur d'exécution'9': L'indice n'appartient pas à la sélection."

Peut-être devrais-je faire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For Each

au lieu de

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For J = 2 To Cells(Application.Rows.Count, 2).End(xlUp).Row

Mais je trouve pas comment faire.

Bonne soirée

Invité · 26/06/2020, 04h11

Envoyé par brunohampert

Bonjour,

Instanciez Ws directement comme ci-dessous, sans faire de Select, et chaque fois que vous utilisez Cells, rattachez le à Ws comme ci-dessous.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
    Set Ws = Sheets("Recapitulatif")
    Form_Mail.Show
 
    For J = 2 To Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row
 
    '....
 
   Next J
 
  Set Ws = Nothing

Envoyer une feuilles du classeur actif en pièce jointe via CDO [XL-2016]

Macros et VBA Excel

Discussions similaires

Partager

Partager