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 |
Partager