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
| Option Compare Database
Option Explicit
Public Function IsOutLookRunning() As Boolean
On Error Resume Next
Dim objOutLook As Object
'Référence vers l'objet Application Outlook
Set objOutLook = GetObject(, "OutLook.Application")
'Si outlook n'est pas ouvert
If (Err <> 0) Then
IsOutLookRunning = False
Else
IsOutLookRunning = True
End If
Set objOutLook = Nothing
End Function
Function EnvoiEmail(cheminfichier As String, TA_mail As String, Objet_Message As String, Corps_Message As String, objOutLook As Object) As Boolean
'On Error GoTo Erreur_EnvoiEMail
Dim objMessage As Object ' Outlook.MailItem ' variable objet pour faire référence au mail
Set objMessage = objOutLook.createitem(0) ' création de l'objer Outlook.MailItem
With objMessage
.To = TA_mail ' on copie l'adresse mail du destinataire
.Subject = Objet_Message ' on copie l'objet du message
'Corps du message
.BodyFormat = 3 'olFormatRichText : on définit le format Texte enrichi
.HTMLBody = Corps_Message
If (cheminfichier <> "") Then ' si un chemin de fichier est passé en argument
objMessage.Attachments.Add cheminfichier ' on attache le fichier au mail
End If
.Display ' envoi de l'e-mail
EnvoiEmail = True ' on indique que tout c'est bien passé
End With
'Libérer la mémoire
Set objMessage = Nothing
' on sort de la fonction
Exit Function
Erreur_EnvoiEmail:
' Gestion de l'erreur
Select Case Err.Number
Case -2147467259 ' adresse invalide
MsgBox "Adresse e-mail invalide"
Case 2501
MsgBox Err.Number & " " & Err.Description
End Select
' si le message n'a pas été envoyé on le signale en renvoyant la valeur False
EnvoiEmail = False
End Function
Public Function EnvoiDocuments(Optional Automatique As Boolean = False) As Boolean
'Automatique : argument optionnel indiquant si la fonction s'exécute automatiquement ou pas.
On Error GoTo err_EnvoiDocuments
Dim fso As Object ' variable objet FSO
Dim nomDossier As String ' variable pour le nom du dossier de sauvegarde des documents pdf
Dim cheminfichier As String ' variable pour le chemin complet du document pdf
Dim TA_nom As String ' nom du TA
Dim db As DAO.Database ' variable objet pour faire référence à la base de données
Dim rsMsg As DAO.Recordset ' variable objet pour faire référence au recordset lié au message à envoyer
Dim rsRelance As DAO.Recordset ' variable objet pour faire référence au recordset lié aux réabonnements
Dim objOutLook As Object ' variable objet pour faire référence à l'application Outlook
Set db = CurrentDb ' référence à la base de données courante
' on ouvre le recordset basé sur la table T_Message_Reabonnement
Set rsMsg = db.OpenRecordset("Message_Relance", dbOpenSnapshot)
' on vérifie si l'objet et le corps du message ont été saisis
If Nz(rsMsg!Objet_Message, "") = "" Then
MsgBox ("Saisir un objet pour le message des destinataires !")
Exit Function
End If
If Nz(rsMsg!Corps_Message, "") = "" Then
MsgBox ("Saisir un message pour les destinataires !")
Exit Function
End If
' on ouvre le recordset contenant la liste des réabonnement en attente n'ayant pas encore fait l'objet d'un envoi
Set rsRelance = db.OpenRecordset("select * from R_Relance_TA where (Envoi=False) and nz(TA_mail,"""")<>"""";", dbOpenDynaset)
If Not rsRelance.EOF Then ' s'il y a des documents à envoyer
If MsgBox("Souhaitez-vous envoyer les documents pour les relances ?", vbYesNo + vbQuestion) = vbYes Then ' si on confirme l'envoi
' Teste si outlook est ouvert, si pas ouvert le lance :
If Not IsOutLookRunning() Then
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
oShell.Run "outlook"
Set oShell = Nothing
End If
'Assigner l'objet Outlook
Set objOutLook = CreateObject("Outlook.Application") 'New Outlook.Application
' création de l'objet FSO
Set fso = CreateObject("Scripting.FileSystemObject")
' indique le chemin du dossier de destination pour les fichiers générés, si pas de dossier d'enregistré dans la table T_Dossier_Documents,
' alors copie le chemin du dossier situé dans le répertoire de la base de données Access
nomDossier = Nz(DLookup("CheminDossier", "T_Dossier_Documents"), CurrentProject.Path & "\Relances") ' indiquez ici le chemin de votre dossier de destination pour les fichiers pdf
If Dir(nomDossier, vbDirectory) = "" Then '
fso.CreateFolder nomDossier
End If
Do Until rsRelance.EOF ' on parcourt la liste des abonnements à renouveler
TA_nom = rsRelance!TA_nom ' on copie le nom complet du TA dans la variable
' on copie le chemin complet dans la variable
cheminfichier = nomDossier & "\Relances " & TA_nom & ".pdf"
' ouverture de l'état filtré avec l'identifiant du TA
DoCmd.OpenReport "E_Relance_TA", acViewPreview, , "TA_id=" & rsRelance!TA_id
' génération du document pdf à partir de l'état filtré avec l'identifiant du TA
DoCmd.OutputTo acOutputReport, "E_Relance_TA", "PDF", cheminfichier
' fermeture de l'état
DoCmd.Close acReport, "E_Relance_TA"
' envoi du message au destinataire
If EnvoiEmail(cheminfichier, rsRelance!TA_mail, rsMsg!Objet_Message, rsMsg!Corps_Message, objOutLook) Then ' si l'envoi du mail s'est bien passé
rsRelance.Edit
rsRelance!Tr_date_relance = Date ' on met à jour le champ Tr_date_relance pour indiquer que l'envoi a bien été effectué
rsRelance.Update
End If
' on passe à l'enregistrement suivant
rsRelance.MoveNext
Loop
EnvoiDocuments = True ' on indique que les documents ont été envoyés
MsgBox "Documents envoyés !", vbExclamation ' on affiche un message pour indiquer que les documents ont bien été envoyés
End If
Else ' sinon, si pas de document à envoyer
If Not Automatique Then ' si la fonction ne s'exécute pas à l'ouverture de la base
MsgBox "Pas de document à envoyer pour les relances !", vbExclamation ' on affiche un message pour indiquer qu'il n'y a pas d'abonnement à renouveler
End If
EnvoiDocuments = False ' la fonction renvoie False
End If
err_EnvoiDocuments:
'gestion d'erreur
If Err.Number <> 0 And Not EnvoiDocuments Then ' si une erreur s'est produite et que les documents n'ont pas été envoyés
MsgBox Err.Description, vbExclamation ' on affiche le message d'erreur
MsgBox "Erreur au cours de l'envoi !", vbExclamation
EnvoiDocuments = False
End If
' libère les variables objet
Set fso = Nothing
If Not (rsMsg Is Nothing) Then
rsMsg.Close
End If
If Not (rsRelance Is Nothing) Then
rsRelance.Close
End If
Set rsMsg = Nothing
Set rsRelance = Nothing
Set db = Nothing
Set objOutLook = Nothing
End Function |
