Forum - Problèmes liés à mes codes mis à disposition - SendMail CDO
2 membres
Connectés : ( personne )
Sujet n° 804
le 11/04/2018 16:33
par possible924
visiteur
[ 1 2 ] |
Réponse n° 11
--------
le 21/04/2018 16:49
par possible924
visiteur
Merci pour la réponse
Private Sub EnvoyerAvec_Click() 'par messagerie 'On utilise le Numéro de facture et non pas CléP_Facture On Error GoTo Fin If NbFactAvec >= 1 Then DoCmd.SetWarnings False 'Purge de la table des factures à envoyer par messagerie DoCmd.RunSQL "Delete T_Factures_Envoi_Messagerie.CléP_Facture_Envoi_Messagerie FROM T_Factures_Envoi_Messagerie" 'Peuplement de la table des factures à envoyer par messagerie "T_Factures_Envoi_Messagerie" DoCmd.OpenQuery "R_Factures_Envoi_Messagerie_PeuplementTable" Dim NbFact_à_Envoyer As Integer Dim FirstFactNuméro As Variant Dim qdf As DAO.QueryDef Set qdf = CurrentDb.QueryDefs!R_Factures_Etat Dim Destinataire As String Dim ObjetDuMessage As String Dim PièceJointe As String Dim Sender As String Dim BodyText As String Sender = DFirst("Email_Expéditeur", "T_Constantes") Do NbFact_à_Envoyer = DCount("FeM_Facture_Imprimé_PDF", "T_Factures_envoi_Messagerie", "FeM_Facture_Imprimé_PDF = 0") FirstFactNuméro = DMin("FeM_Facture_Numéro", "T_Factures_envoi_Messagerie", "FeM_Facture_Imprimé_PDF = 0") qdf.SQL = "SELECT R_Factures.*, R_Facture_Contenu.* FROM R_Factures LEFT JOIN R_Facture_Contenu " & _ "ON R_Factures.CléP_Facture = R_Facture_Contenu.FC_Clé_Facture " & _ "WHERE R_Factures.Fact_Numéro = " & FirstFactNuméro Destinataire = DLookup("FeM_Messagerie_Destinataire", "T_Factures_Envoi_Messagerie", "FeM_Facture_Numéro = " & FirstFactNuméro) ObjetDuMessage = "Notre facture du " & DLookup("FeM_Facture_Date", "T_Factures_Envoi_Messagerie", "FeM_Facture_Numéro = " & FirstFactNuméro) BodyText = "A l'attention de " & _ DLookup("FeM_Personne_Destinataire", "T_Factures_Envoi_Messagerie", "FeM_Facture_Numéro = " & FirstFactNuméro) & vbCrLf & vbCrLf & _ DFirst("Corps_Message", "T_Constantes") PièceJointe = "W:BasesIrisFacturesEnvoiMessagerie" & DLookup("FeM_PDF_Nom", "T_Factures_Envoi_Messagerie", "FeM_Facture_Numéro =" & FirstFactNuméro) DoCmd.RunSQL "UPDATE T_Factures_Envoi_Messagerie SET T_Factures_Envoi_Messagerie.FeM_Facture_Imprimé_PDF = -1 " & _ "WHERE T_Factures_Envoi_Messagerie.FeM_Facture_Numéro = " & FirstFactNuméro 'Crée le document PDF correspondant à la facture DoCmd.OutputTo acOutputReport, "E_Facture", "PDFFormat(*.pdf)", "W:BasesIrisFacturesEnvoiMessagerie" & DLookup("FeM_PDF_Nom", "T_Factures_Envoi_Messagerie", "FeM_Facture_Numéro =" & FirstFactNuméro), False, "", , acExportQualityScreen 'Envoie l'Email avec la facture jointe Dim Cdo_Message As New CDO.Message Set Cdo_Message.Configuration = GetSMTPServerConfig() With Cdo_Message .From = Sender .To = Destinataire .Subject = ObjetDuMessage .TextBody = BodyText .addAttachment (PièceJointe) .Send End With Set Cdo_Message = Nothing 'Met à joiur la date d'envoi de la facture DoCmd.RunSQL "UPDATE T_Factures SET T_Factures.Fact_Date_EnvoiMessagerie = " & Date * 1 & " WHERE T_Factures.Fact_Numéro = " & FirstFactNuméro Me.NbPDFEnvoyés = NbFactAvec - NbFact_à_Envoyer + 1 Loop Until NbFact_à_Envoyer = 1 'Vider le répertoire "W:BasesIrisFacturesEnvoiMessagerie" Me.Refresh Kill "W:BasesIrisFacturesEnvoiMessagerie*.pdf" Else If MsgBox("Il n'y a aucune facture sélectionnée !" & (vbCrLf & vbCrLf) & _ "Vous devez sélectionner des factures" & vbCrLf & _ "pour pouvoir les voir, les imprimer" & vbCrLf & _ "ou bien les envoyer par messagerie." & vbCrLf & _ "" & (vbCrLf), vbApplicationModal, CurrentDb.Properties("AppTitle")) = vbOK Then Exit Sub End If DoCmd.SetWarnings True 'Remet la requête de la facture d'origine qdf.SQL = "SELECT R_Factures.*, R_Facture_Contenu.* FROM R_Factures LEFT JOIN R_Facture_Contenu ON R_Factures.CléP_Facture = R_Facture_Contenu.FC_Clé_Facture" Set qdf = Nothing If MsgBox("Toutes les factures sélectionnées" & vbCrLf & _ "et dont le destinataire possède une adresse de messageie valide" & vbCrLf & _ "ont été envoyées par messagerie Internet." & (vbCrLf), vbInformation, CurrentDb.Properties("AppTitle")) = vbOK Then Exit Sub Exit Sub Fin: DoCmd.SetWarnings True 'Remet la reqête de la facture d'origine qdf.SQL = "SELECT R_Factures.*, R_Facture_Contenu.* FROM R_Factures LEFT JOIN R_Facture_Contenu ON R_Factures.CléP_Facture = R_Facture_Contenu.FC_Clé_Facture" Set qdf = Nothing If MsgBox("Oh ! Fan des pieds," & vbCrLf & _ "Encore une cagatte." & vbCrLf & vbCrLf & _ "Pour des raisons inconnues," & vbCrLf & _ "le processus d'envoi des messages a été interrompu." & vbCrLf & vbCrLf & _ "Vous pouvez tenter d'envoyer à nouveau les messages" & vbCrLf & _ "mais ne selectionnez pas ceux qui ont déja une date d'envoi.", vbCritical, CurrentDb.Properties("AppTitle")) = vbOK Then Exit Sub End Sub
J'ai pris note de tes remarques et modifié le code comme ci dessus, et ça marche très bien.
Merci pour tout, et toutes tes remarques sont les bienvenues
Pierre
sujet actif
sujet clos
Important!
Nouveau
Rectifier message
Clôturer sujet
Remonter sujet