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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
Option Explicit
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) _
As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
'Déclaration de la fonction AdresseEamilValide de type boellean qui va renvoyer true ou false
'La Fonction attend un paramètre de type entier ByVal permet de prendre en compte seulement sa valeur
Function VerificationAdresseEmail(ByVal email As String) As Boolean
'Si il y a une reeur pendant l'exécution du code tu vas stocker l'erreur dans VerificationAdresseEmailIncorrecte
On Error GoTo VerificationAdresseEmailIncorrecte
'Définition des constantes
Const CaracteresAutorise1 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890.!#$%&'*+-/=?^_`{|}~"
Const CaracteresAutorise2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890.-"
'Déclaration des variables de type chaine de caractères
Dim AvantAdresseEmail, ApresAdresseEmail, AntiDoublePoint As String
'Déclaration de variable de type entier
Dim EmplacementArobase, i As Integer
'On recherche le symbole @ dans la chaine de caractère attendu par la fonction
'Cette recherche est affecté à la variable EmplacementArobase
EmplacementArobase = InStr(1, email, "@")
'Si la recherche retourne 0 on va faire un lien vers VerificationAdresseEmailIncorrecte
'Qui sera la variable ou on stock tous nos erreurs
If EmplacementArobase = 0 Then GoTo VerificationAdresseEmailIncorrecte
'Si la recherche est supérieure à 0 on va faire un lien direct vers VerificationAdresseEmailIncorrecte
If InStr(EmplacementArobase + 1, email, "@") > 0 Then GoTo VerificationAdresseEmailIncorrecte
'La fonction Left permet de renvoyer le nombre de caractères de la chaine voulu en partent de la gauche
'La variable AvantAdresseEmail va contenir tout ce qui se trouve avant le symbole @
AvantAdresseEmail = Left(email, EmplacementArobase - 1)
'La fonction Right permet de renvoyer le nombre de caractère de la chaine voulu en partent de la droite
'la fonction len permet de déterminer le nombre de caractère dans une chaine
'la variable ApresAdresseEmail va contenir tout ce qui se trouve à droite du symbole @ (y compris les points)
ApresAdresseEmail = Right(email, Len(email) - EmplacementArobase)
'La variable AntiDoublePoint va rechercher tout ce qui se trouve à droite du symbole @ et va sauvegarder la position des points
AntiDoublePoint = Right(email, Len(email) - InStrRev(email, "."))
'Début des conditions
'Cette condition teste s'il y a un point au début de la chaine de caractère AvantAdresseEmail et à la fin de cette chaine
If Left(AvantAdresseEmail, 1) = "." Or Right(AvantAdresseEmail, 1) = "." Then GoTo VerificationAdresseEmailIncorrecte
'Cette condition teste s'il n'y a pas de point dans la chaine de caractère ApresAdresseEmail
If InStr(1, ApresAdresseEmail, ".") = 0 Then GoTo VerificationAdresseEmailIncorrecte
'Cette condition teste s'il y a un point au début de la chaine de caractère ApresAdresseEmail et à la fin de cette chaine
If Left(ApresAdresseEmail, 1) = "." Or Right(ApresAdresseEmail, 1) = "." Then GoTo VerificationAdresseEmailIncorrecte
'Cette condition teste s'il y a un tiret au début de la chaine de caractère ApresAdresseEmail et à la fin de cette chaine
If Left(ApresAdresseEmail, 1) = "-" Or Right(ApresAdresseEmail, 1) = "-" Then GoTo VerificationAdresseEmailIncorrecte
'Cette condition teste s'il y a moins de deux caractère dans la chaine de caractère AntiDoublePoint
If Len(AntiDoublePoint) < 2 Then GoTo VerificationAdresseEmailIncorrecte
'Cette boucle vérifie chaque caractère de la variable AvantAdresseEmail n'est pas différent des caractères
'situés dans la variable CaracteresAutorise1
For i = 1 To Len(AvantAdresseEmail)
If InStr(1, CaracteresAutorise1, Mid(AvantAdresseEmail, i, 1)) = 0 Then GoTo VerificationAdresseEmailIncorrecte
Next i
'Cette boucle vérifie chaque caractère de la variable ApresAdresseEmail n'est pas différent des caractères
'situés dans la variable CaracteresAutorise1
For i = 1 To Len(ApresAdresseEmail)
If InStr(1, CaracteresAutorise2, Mid(ApresAdresseEmail, i, 1)) = 0 Then GoTo VerificationAdresseEmailIncorrecte
Next i
'Cette boucle vérifie qu'il n'y a pas deux points de suite dans la chaine de caractère entrée par l'utilisateur
For i = 1 To Len(email)
If Mid(email, i, 1) = "." And Mid(email, i + 1, 1) = "." Then GoTo VerificationAdresseEmailIncorrecte
Next i
'Si toutes les conditions n'ont pas retourné d'erreur tu quitte la fonction et tu retournes True
VerificationAdresseEmail = True
Exit Function
'Si une des conditions a retourné une erreur tu quittes la fonction et tu retournes False
VerificationAdresseEmailIncorrecte:
VerificationAdresseEmail = False
End Function
'Déclaration de la fonction VerifierDossierEtSousDossier de type boellean qui va renvoyer true ou false
'La Fonction attend un paramètre de type entier
Function VerifierDossierEtSousDossier(DossierOuSousDossier As String) As Boolean
Dim DecouperDossierOuSousDossier, DecouperDossierOuSousDossier2, CheminPartiel, CheminPartielOK As Variant
'Si il y a une reeur pendant l'exécution du code tu vas stocker l'erreur dans VerifierDossierEtSousDossierErreur
On Error GoTo VerifierDossierEtSousDossierErreur
'cette fonction vérifi si le répertoire ou dossier de l'utilisateur existe déja
'Len permet de conter le nombre de caractère
'Dir renvoie une valeur entier représentant le non du dossier ou fichier il prend en paramètre
'le chemin d'accès et un attributs ici vbDirectory qui permet dans qu'elle dossier ou sous dossier il est situé
If Len(Dir(DossierOuSousDossier, vbDirectory)) > 0 Then
VerifierDossierEtSousDossier = True
Exit Function
Else
'si le fichier ou dossier n'existe pas
'Cette ondition teste si il y a un \ à la fin de la chaine de caractère DossierOuSousDossier
If Right(DossierOuSousDossier, 1) = Application.PathSeparator Then
'DossierOuSousDossier est égal au nombre de caratère -1 pour enlever le symbole \
DossierOuSousDossier = Left(DossierOuSousDossier, Len(DossierOuSousDossier) - 1)
'ici on va extraire les donnée qui sont séparé par le symbole \ dans la chaine
'de carractère DecouperDossierOuSousDossier, ce qui va renvoyer un tableau unidimensionnel de base zéro
DecouperDossierOuSousDossier = Split(DossierOuSousDossier, Application.PathSeparator)
'Cette boucle permet déterminer la taille du tableau DecouperDossierOuSousDossier créer antérièrement
For DecouperDossierOuSousDossier2 = LBound(DecouperDossierOuSousDossier) To UBound(DecouperDossierOuSousDossier)
For CheminPartiel = LBound(DecouperDossierOuSousDossier) To DecouperDossierOuSousDossier2
CheminPartielOK = CheminPartielOK & DecouperDossierOuSousDossier(CheminPartiel) & Application.PathSeparator
If CheminPartiel = DecouperDossierOuSousDossier2 Then
If Len(Dir(CheminPartielOK, vbDirectory)) = 0 Then
MkDir CheminPartielOK
End If
End If
Next CheminPartiel
CheminPartielOK = ""
Next DecouperDossierOuSousDossier2
End If
End If
VerifierDossierEtSousDossier = True
Exit Function
VerifierDossierEtSousDossierErreur:
VerifierDossierEtSousDossier = False
End Function
Private Sub email_Click()
Dim ObjOutlook As Outlook.Application
Dim oBjMail
Dim Piecejointe As Variant
Dim base, Model, Rep, Dossier, Fiche, Destinataire, Nom, Prenom, Dates, MonDossier, Residences, DossierComplet, Numappt, Numfact, Datesfact, ResidencesH, VerificationEmail As String
Dim Feuille As Worksheet
Dim L As Long
Dim WordApp As Object ' Application Word
Dim WordDoc As Object ' Document Word
Dim i, nblignes As Integer
Dim NB As Variant
Dim lngHWnd, lngClickYes As Long
Dim OutlookDejaOuvert As Boolean
OutlookDejaOuvert = True
Set ObjOutlook = Outlook.Application
Set Feuille = Worksheets("MAIL")
Feuille.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh
NB = Application.CountA(Sheets("MAIL").Range("A2:A65536"))
L = 2
If ObjOutlook.ActiveWindow Is Nothing Then
Set ObjOutlook = CreateObject("Outlook.Application")
OutlookDejaOuvert = False
End If
For i = 1 To NB
Set oBjMail = ObjOutlook.CreateItem(olMailItem)
Destinataire = Feuille.Cells(L, 12).Value
Nom = Feuille.Cells(L, 6).Value
Prenom = Feuille.Cells(L, 7).Value
Dates = Feuille.Cells(L, 3).Value
Residences = Feuille.Cells(L, 1).Value
Numappt = Feuille.Cells(L, 5).Value
Numfact = Feuille.Cells(L, 14).Value
Datesfact = Feuille.Cells(L, 13).Value
' Désactive l'actualisation de l'écran (accélère l'exécution du code)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Définition des variables
base = ActiveWorkbook.Path & "\test.xlsm"
Model = ActiveWorkbook.Path & "\test.docx"
Dossier = ActiveWorkbook.Path & "\Factures\"
'cette fonction vérifi si le répertoire Factures existe ou pas, si n'existe pas il le créer
If Not Len(Dir(Dossier, vbDirectory)) > 0 Then MkDir Dossier
' Ouvre une session word (création de fichier)
Set WordApp = CreateObject("Word.Application")
' Cache le document Word
WordApp.Visible = False
' Ouvre le document souhaité
Set WordDoc = WordApp.Documents.Open(Model, ReadOnly:=False)
'début d'éxecution d'une série
With WordDoc.MailMerge
'Ouvre la base
.OpenDataSource Name:=base, Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & base & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [MAIL$]"
.suppressBlankLines = True 'Suppression des lignes blanches
'nombre d'enregistrement à associé
With .DataSource
.FirstRecord = i 'de 1
.LastRecord = i ' à 1
End With
'Exécute l'opération de publipostage
.Execute Pause:=False
End With
VerificationEmail = VerificationAdresseEmail(Destinataire)
If VerificationEmail = False Then
Destinataire = "Facture de" & Residences & "-" & Numappt & "-" & Datesfact & "-" & Numfact & "@espaceetvie.fr"
End If
Rep = Residences & "\"
DossierComplet = Dossier & Rep
VerifierDossierEtSousDossier (DossierComplet)
' Définition du non du fichier
Fiche = DossierComplet & Residences & "-" & Numappt & "-" & Nom & "-" & Prenom & "-" & Datesfact & "-" & Numfact
'enregistrement du fichier en PDF
WordDoc.Application.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
Fiche, ExportFormat:= _
17, OpenAfterExport:=False, OptimizeFor:= _
0, Range:=0, From:=i, To:=NB, _
Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=0, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
WordApp.ActiveDocument.Saved = True
WordApp.ActiveDocument.Close
WordDoc.Close False 'ferme le document word en sauvegardant les données
WordApp.Quit 'ferme la session Word
Set WordApp = Nothing
Set WordDoc = Nothing
Piecejointe = Fiche & ".pdf"
With oBjMail
.To = Destinataire
.Subject = "Espace & Vie - Facture de" & Residences & "-" & Numappt & Nom & "-" & Prenom & "-" & Datesfact & "-" & Numfact
.BodyFormat = olFormatRichText
.Body = "Madame, Monsieur," & vbLf & vbLf & "Veuillez trouvez, ci-joint, votre facture comme convenu contractuellement." & vbLf & vbLf & "Bien cordialement" & vbLf & vbLf & "Monique GUILLET" & vbLf & "0800111300" & vbLf & " "
.Attachments.Add Piecejointe
.Send
End With
L = L + 1
Next i
ResidencesH = Feuille.Cells(2, 1).Value
For nblignes = 1 To NB
Residences = Feuille.Cells(2, 1).Value
If ResidencesH <> Residences Then
With Sheets("envoie de mail")
L = .Range("H65536").End(xlUp).Row + 1
.Range("H" & L).Value = Residences
.Range("I" & L).Value = Now()
.Range("J" & L).Value = Datesfact
.Range("K" & L).Value = Numfact
End With
End If
Next nblignes
If (Not (WordApp Is Nothing)) Then Set WordApp = Nothing
If (Not (WordDoc Is Nothing)) Then Set WordDoc = Nothing
If OutlookDejaOuvert = False Then
ObjOutlook.Quit
SendMessage lngHWnd, lngClickYes, 1, 0
If (Not (oBjMail Is Nothing)) Then Set oBjMail = Nothing
If (Not (ObjOutlook Is Nothing)) Then Set ObjOutlook = Nothing
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Emails envoyés"
End Sub |
Système d'hystorique vba excel
).
Répondre avec citation
Partager