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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
| Option Explicit
' -------------------------------------------------------------------------
' PROCEDURE PRINCIPALE : ORCHESTRATION MÉTIER
' Rôle : Valider les données, générer le document, déclencher l'envoi.
' -------------------------------------------------------------------------
Sub Traitement_Facture_Complet()
Dim ws As Worksheet
Dim Dossier As String, CheminDossier As String
Dim NomFichier As String, CheminComplet As String
Dim EmailClient As String
Dim RawName As String
' Initialisation de la feuille active
Set ws = ActiveSheet
' --- ÉTAPE 1 : Validation Utilisateur et Données ---
If MsgBox("Confirmez-vous l'exportation et l'envoi de la facture par email?", _
vbYesNo + vbQuestion, "Confirmation d'envoi") = vbNo Then Exit Sub
' Vérification de la présence d'un email valide en cellule L10
EmailClient = Trim(ws.Range("L10").Value)
If InStr(EmailClient, "@") = 0 Or InStr(EmailClient, ".") = 0 Then
MsgBox "ERREUR CRITIQUE :" & vbCrLf & _
"L'adresse email du client en cellule L10 est invalide ou manquante.", _
vbExclamation, "Données Invalides"
Exit Sub
End If
' --- ÉTAPE 2 : Gestion du Système de Fichiers ---
' Utilisation de ThisWorkbook.Path pour garantir la portabilité du script
Dossier = "Factures PDF"
CheminDossier = ThisWorkbook.Path & "\" & Dossier & "\"
' Création sécurisée du répertoire s'il n'existe pas
' La fonction Dir vérifie l'existence sans lever d'erreur
If Dir(CheminDossier, vbDirectory) = "" Then
On Error Resume Next
MkDir CheminDossier
If Err.Number <> 0 Then
MsgBox "Impossible de créer le dossier de sauvegarde." & vbCrLf & _
"Vérifiez vos droits d'écriture.", vbCritical
Exit Sub
End If
On Error GoTo 0
End If
' --- ÉTAPE 3 : Construction et Sanitisation du Nom de Fichier ---
' Nettoyage des caractères interdits dans les noms de fichiers Windows (\ / : *? " < > |)
RawName = ws.Range("E5").Value & "_" & ws.Range("L1").Value
RawName = Replace(RawName, "/", "-")
RawName = Replace(RawName, "\", "-")
NomFichier = RawName & ".pdf"
CheminComplet = CheminDossier & NomFichier
' --- ÉTAPE 4 : Exportation PDF ---
' Utilisation de la méthode native ExportAsFixedFormat
On Error GoTo ErreurExport
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=CheminComplet, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error GoTo 0
' --- ÉTAPE 5 : Transmission au Service de Messagerie ---
' Passage des arguments critiques à la sous-procédure
Call EnvoyerMailGmail(CheminComplet, EmailClient)
Exit Sub
ErreurExport:
MsgBox "Erreur lors de la génération du fichier PDF." & vbCrLf & _
"Détails : " & Err.Description, vbCritical
End Sub
' -------------------------------------------------------------------------
' SOUS-PROCÉDURE : COUCHE DE TRANSPORT SMTP (CDO)
' Rôle : Configurer le schéma CDO et négocier la connexion SSL avec Gmail.
' -------------------------------------------------------------------------
Sub EnvoyerMailGmail(FichierJoint As String, Destinataire As String)
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Object
Dim Schema As String
' Définition de l'espace de noms du schéma CDO
' Note : Ce n'est pas une URL web, mais une clé de registre interne à la DLL
Schema = "http://schemas.microsoft.com/cdo/configuration/"
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' Chargement des configurations par défaut
iConf.Load -1
Set Flds = iConf.Fields
With Flds
' --- CONFIGURATION RÉSEAU ET SÉCURITÉ ---
' sendusing : 2 = Envoi via le réseau (SMTP)
.Item(Schema & "sendusing") = 2
' Serveur SMTP de Gmail
.Item(Schema & "smtpserver") = "smtp.gmail.com"
' Port 465 : Force le mode SMTPS (Implicit SSL)
' C'est la configuration la plus stable pour CDO/Gmail
.Item(Schema & "smtpserverport") = 465
' Activation du chiffrement SSL/TLS
.Item(Schema & "smtpusessl") = True
' Timeout de connexion (en secondes) - Augmenté pour l'envoi de PDF
.Item(Schema & "smtpconnectiontimeout") = 60
' --- AUTHENTIFICATION ---
' smtpauthenticate : 1 = Authentification Basique (Requise pour App Password)
.Item(Schema & "smtpauthenticate") = 1
' Identifiants de l'expéditeur
' CORRECTION IMPORTANTE : "sendusername" et non "senusername"
.Item(Schema & "sendusername") = "votre.asso@gmail.com"
' MOT DE PASSE D'APPLICATION (16 caractères générés par Google)
' Ne jamais utiliser le mot de passe de connexion Gmail ici
.Item(Schema & "sendpassword") = "xxxx xxxx xxxx xxxx"
.Update
End With
' --- CONSTRUCTION DE L'ENVELOPPE MESSAGE ---
With iMsg
Set.Configuration = iConf
.To = Destinataire
.From = "votre.asso@gmail.com"
.CC = "" ' Copie carbone optionnelle
.Subject = "CSD Tennis de Table – Facture " & Range("E5").Value
' Corps du message en texte brut
.TextBody = "Bonjour," & vbCrLf & vbCrLf & _
"Veuillez trouver ci-joint votre facture relative à vos engagements." & vbCrLf & vbCrLf & _
"Ce message est généré automatiquement." & vbCrLf & _
"Cordialement," & vbCrLf & "L'équipe Tennis de Table"
' Attachement dynamique du fichier PDF généré précédemment
If FichierJoint <> "" Then
.AddAttachment FichierJoint
End If
' --- TENTATIVE D'ENVOI AVEC GESTION D'ERREUR ---
On Error Resume Next
.Send
If Err.Number <> 0 Then
' Analyse des erreurs fréquentes pour guider l'utilisateur
Dim MsgErreur As String
MsgErreur = "ÉCHEC DE L'ENVOI." & vbCrLf & vbCrLf & _
"Code Erreur : " & Err.Number & vbCrLf & _
"Description : " & Err.Description & vbCrLf & vbCrLf & _
"Pistes de résolution :" & vbCrLf & _
"1. Vérifiez que le 'Mot de passe d'application' est correct." & vbCrLf & _
"2. Vérifiez votre connexion internet." & vbCrLf & _
"3. Assurez-vous qu'aucun pare-feu ne bloque le port 465."
MsgBox MsgErreur, vbCritical, "Erreur SMTP"
Else
MsgBox "La facture a été envoyée avec succès à :" & vbCrLf & Destinataire, vbInformation, "Succès"
End If
On Error GoTo 0
End With
' Nettoyage mémoire (essentiel en VBA pour éviter les fuites)
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub |
Exporter une facture en PDF et l'envoyer directement par mail sans outlook.
Répondre avec citation
Envoyé par zaza62000
Partager