Génération d'un pdf avec envoi d'email

**dolu007** · 06/06/2013, 11h13

Bonjour,

Voici mon environnement :
Windows 7 pro 64 bits
Office 2010 32 bits
Outlook exchange
Pdf Creator

Prérequis : je ne maitrise que très peu le language vba

Je souhaite générer à partir d'une feuille excell, un fichier pdf avec un envoi d'email. J'ai trouvé le script ci-dessous, mais un message d'erreur arrive à la ligne ".send" Le fichier pdf est toutefois généré.

Message d'erreur :

Erreur d'exécution '-2147220960 (80040220)'
La valeur de configuration "SendUsing" est non valide.

J'ai passé 2 jours sur plusieurs forum à chercher une solution mais en vain...
Voici le 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
56
57
58
59
60
 
'   http://sourceforge.net/projects/pdfcreator   PDFCreator-0_9_3_GPLGhostscript.exe
 '   sous VBA Menu Outils | Références  Cocher PDFCreator
'   sous VBA Menu Outils | Références  Cocher Microsoft CDO for Exchange xxxx Library
 
Sub Tst_PdfCreator()
Dim objMessage As CDO.Message
Dim jobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
 
    sNomPDF = "Essai.pdf"
    sCheminPDF = ActiveWorkbook.Path & Application.PathSeparator
 
    If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
 
    Set jobPDF = CreateObject("PDFCreator.clsPDFCreator")
 
    With jobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
             Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
 
        '0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With
 
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"
 
    'Fichier dans la file d'attente
    Do Until jobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    jobPDF.cPrinterStop = False
 
    'Attendre que la file d'attente soit vide
    Do Until jobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop
    jobPDF.cClose
    Set jobPDF = Nothing
 
    Set objMessage = CreateObject("CDO.Message")
    With objMessage
        .Subject = "Essai"
        '.From = "qsdqssdsqdsq@qdsdsdsdqs.fr"
        .To = "qsdsqdqsd@qsdqsdqdqsd.fr"
        .TextBody = "Texte dans le corps de message"
        .AddAttachment sCheminPDF & sNomPDF
        .Send
    End With
 
    Set objMessage = Nothing
End Sub

Invité · 06/06/2013, 21h36

Bonjour,

Un précédent mail traitant des paramètres CDO pour envoyer un mail :

http://www.developpez.net/forums/d13...ssier-a-email/

Cordialement.

**dolu007** · 07/06/2013, 11h37

Bonjour Eric,

Je tente de partir de ton code mais le programme bute sur des fonctions, comme la fonction "ControlerLesDroitsDUtilisation". Il doit me manquer des librairies... :

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
 
Sub EditerAuFormatPdf_PdfCreator()
 
Dim ObjMessage As Object
Dim JobPDF As Object
Dim NomConcatene As String
 
Const cdoSendUsingPickup = 1 'Envoyer un message en utilisant le répertoire SMTP local de ramassage de service.
Const cdoSendUsingPort = 2 'Envoyer le message en utilisant le réseau (SMTP sur le réseau).
'Const cdoAnonymous = 0 'Ne pas authentifier
'Const cdoBasic = 1 'de base (clair- texte) d'authentification Const cdoNTLM = 2 'NTLM
 
    Continuer = True
    Call ControlerLesDroitsDUtilisation
    If Continuer = False Then Exit Sub
 
 
    RepertoireSauvegarde = Sheets("Paramètres").Range("RepertoireSauvegardes")
 
    ChDir RepertoireSauvegarde
 
    CompetitionNomEpreuve = Sheets("Inscriptions").Range("CompetitionChoisie")
    CompetitionDateEpreuve = DateDeCreationMail(Sheets("Inscriptions").Range("CompetitionDate"))
    AdresseMailDestinataire = Sheets("Modèle facture").Range("MailDestinataireFacture")
    AdresseMailEmetteur = Sheets("Modèle facture").Range("MailEmetteurFacture")
 
    NomDuFichier = "Facture " & CompetitionNomEpreuve & " " & CompetitionDateEpreuve & " " & Sheets("Modèle facture").Range("FactureClub") & ".pdf"
    NomConcatene = RepertoireSauvegarde & "\" & NomDuFichier
 
    Sheets("Modèle facture").Activate
 
    If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
 
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")
 
    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
 
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = RepertoireSauvegarde
        .cOption("AutosaveFilename") = NomDuFichier
 
        '-------------------------------------------------------------
        ' 0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
        '-------------------------------------------------------------
        .cOption("AutosaveFormat") = 0
        .cClearCache
 
    End With
 
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"
 
    '------------------------------
    'Fichier dans la file d'attente
    '------------------------------
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False
 
    '----------------------------------------
    'Attendre que la file d'attente soit vide
    '----------------------------------------
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop
 
  '  MsgBox (RepertoireSauvegarde & "\" & NomDuFichier)
 
    JobPDF.cClose
 
    '--------------------------
    ' Envoi du fichier par mail
    '--------------------------
    Set JobPDF = Nothing
 
 
 
    If EnvoyerMail = True Then
 
            Set ObjMessage = CreateObject("CDO.Message")
            With ObjMessage
                    .Subject = NomDuFichier
                    .From = AdresseMailEmetteur
                    .To = AdresseMailDestinataire
                    .TextBody = "Bonjour" & vbCrLf & vbCrLf & "Vous trouverez, ci-joint, une facture correspondant aux inscriptions à une compétition." & vbCrLf & vbCrLf & "Cordialement."
                    .AddAttachment NomConcatene
                    '"== Cette section fournit les informations de configuration pour le serveur SMTP distant.
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/SendUsing") = 2
                    'Nom ou adresse IP du serveur SMTP à distance
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.live.com"
                    ' Type d'authentification, NONE, Basic (Base64 codé), NTLM
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
                    'Votre nom d'utilisateur sur le serveur SMTP
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "VotreAdresse"
                    '"Votre mot de passe sur le serveur SMTP
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "VotreMotDePasse"
                    'serveur "du port (généralement 25)
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport ") = 587
                    'Utiliser SSL pour la connexion (Faux ou Vrai)
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
                    'Connection Timeout en secondes ( le temps maximum CDO va essayer d'établir une connexion au serveur SMTP)
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
                    .Configuration.Fields.Update
 
                    '"== Fin de la section SMTP distant configuration du serveur ==
                   .Send
 
            End With
 
 
            Set ObjMessage = Nothing
 
    End If
 
End Sub

Invité · 07/06/2013, 12h59

Bonjour,

Non pas du tout, il faut supprimer cet appel à la macro, elle ne sert qu'à contrôler des droits d'utilisation dans une de mes applications.

Par contre, il faut vérifier que la dll Microsoft CDO pour Windows soit accessible dans Outils - Références de l'éditeur VBA.

J'ai un peu modifié le code d'origine, il reste quand même à l'adapter si tu souhaites l'inclure dans une boucle.

Mais attention à la protection anti-spam de ton fournisseur d'accès ! Chez Darty par exemple, je me suis aperçu en lançant un mailing que le "robinet" était fermé au bout du 200 ème ou du 250 ème. Il a fallu attendre 24 heures pour pouvoir de nouveau envoyer des mails.

Ce qui est important de mon point de vue, ce sont les paramètres CDO.

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
Sub EditerAuFormatPdf_PdfCreator()
 
Dim ObjMessage As Object
Dim JobPDF As Object
 
Dim NomDuFichier As String
Dim NomConcatene As String
Dim RepertoireSauvegarde As String
Dim AdresseMailDestinataire As String
Dim AdresseMailEmetteur As String
 
Dim Continuer As Boolean
Dim EnvoyerMail As Boolean
 
 
Const cdoSendUsingPickup = 1 'Envoyer un message en utilisant le répertoire SMTP local de ramassage de service.
Const cdoSendUsingPort = 2 'Envoyer le message en utilisant le réseau (SMTP sur le réseau).
'Const cdoAnonymous = 0 'Ne pas authentifier
'Const cdoBasic = 1 'de base (clair- texte) d'authentification Const cdoNTLM = 2 'NTLM
 
    Continuer = True
 
    RepertoireSauvegarde = Sheets("Paramètres").Range("RepertoireSauvegardes")
 
    ChDir RepertoireSauvegarde
 
  '  CompetitionNomEpreuve = Sheets("Inscriptions").Range("CompetitionChoisie")
  '  CompetitionDateEpreuve = DateDeCreationMail(Sheets("Inscriptions").Range("CompetitionDate"))
    AdresseMailDestinataire = Sheets("Modèle facture").Range("MailDestinataireFacture")
    AdresseMailEmetteur = Sheets("Modèle facture").Range("MailEmetteurFacture")
 
    NomDuFichier = "XXXXXXXXXX" & ".pdf"
    NomConcatene = RepertoireSauvegarde & "\" & NomDuFichier
 
    Sheets("Modèle facture").Activate
 
    If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
 
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")
 
    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
 
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = RepertoireSauvegarde
        .cOption("AutosaveFilename") = NomDuFichier
 
        '-------------------------------------------------------------
        ' 0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
        '-------------------------------------------------------------
        .cOption("AutosaveFormat") = 0
        .cClearCache
 
    End With
 
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"
 
    '------------------------------
    'Fichier dans la file d'attente
    '------------------------------
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False
 
    '----------------------------------------
    'Attendre que la file d'attente soit vide
    '----------------------------------------
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop
 
  '  MsgBox (RepertoireSauvegarde & "\" & NomDuFichier)
 
    JobPDF.cClose
 
    '--------------------------
    ' Envoi du fichier par mail
    '--------------------------
    Set JobPDF = Nothing
 
 
 
    If EnvoyerMail = True Then
 
            Set ObjMessage = CreateObject("CDO.Message")
            With ObjMessage
                    .Subject = NomDuFichier
                    .From = AdresseMailEmetteur
                    .To = AdresseMailDestinataire
                    .TextBody = "Bonjour" & vbCrLf & vbCrLf & "Vous trouverez, ci-joint, une facture correspondant aux inscriptions à une compétition." & vbCrLf & vbCrLf & "Cordialement."
                    .AddAttachment NomConcatene
                    '"== Cette section fournit les informations de configuration pour le serveur SMTP distant.
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/SendUsing") = 2
                    'Nom ou adresse IP du serveur SMTP à distance
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.live.com"
                    ' Type d'authentification, NONE, Basic (Base64 codé), NTLM
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
                    'Votre nom d'utilisateur sur le serveur SMTP
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "VotreAdresse"
                    '"Votre mot de passe sur le serveur SMTP
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "VotreMotDePasse"
                    'serveur "du port (généralement 25)
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport ") = 587
                    'Utiliser SSL pour la connexion (Faux ou Vrai)
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
                    'Connection Timeout en secondes ( le temps maximum CDO va essayer d'établir une connexion au serveur SMTP)
                    .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
                    .Configuration.Fields.Update
 
                    '"== Fin de la section SMTP distant configuration du serveur ==
                   .Send
 
            End With
 
 
            Set ObjMessage = Nothing
 
    End If
 
End Sub

Cordialement.

**dolu007** · 12/06/2013, 16h54

J'ai adapté et ça marche nickel. Merci. J'ai une bonne base que je vais pouvoir personnaliser.

Génération d'un pdf avec envoi d'email [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager