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