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
| Sub Mail_avec_Timer()
Dim varHeureExec As Variant
Dim dteDerniereExec As Date
Dim MonApp As Outlook.Application
Dim MonNomSpace As Outlook.NameSpace
Dim MonDossier As Outlook.MAPIFolder
Dim MonDossierArchive As Outlook.MAPIFolder
Dim MonMail As Object
Dim blnEdit As Boolean
Dim strEmailTo As String
Dim strEmailObj As String
Dim strEmailMsg As String
' Lire l'heure de dernière exécution
varDerniereExec = DLookup("[Pl_DernierExec]", "tblPlanification")
' Si une exécution a eu lieu aujourd'hui, annuler le processus
If Format(varDerniereExec, "dd/mm/yyyy") = Format(Now(), "dd/mm/yyyy") Then Exit Sub
' Lire l'heure d'exécution
varHeureExec = DLookup("[DP_HeureExec]", "tblDetectionProgrammee")
If IsNull(varHeureExec) Then Exit Sub
' Comparaison avec l'heure du PC
If Time < varHeureExec Then Exit Sub
' Mémorisation du dernier traitement
CurrentDb.Execute "UPDATE [tblPlanification] SET [Pl_DernierExec]=#" & _
Format(Now, "mm/dd/yyyy hh:nn:ss") & "#"
strDocPDF = "Chemin et nom fichier de sauvegarde.pdf"
DoCmd.OutputTo acOutputReport, dossier recu, acFormatPDF, strDocPDF, False
strEmailObj = "Objet du message"
strEmailMsg = "Texte du message"
' Joindre les pièces, s'il y en a
' .Attachments.Add (strDocPDF)
' Affichage du mail pour éventuellement complémentation (False) et pour envoi (True)
blnEdit = True
' Création d'une instance d'Outlook
On Error GoTo OLMailErr
Set MonApp = New Outlook.Application
' Répertoire "Elements envoyés"
Set MonNomSpace = MonApp.GetNamespace("MAPI")
Set MonDossier = MonNomSpace.GetDefaultFolder(olFolderOutbox)
' Création d'un objet Email
Set MonMail = MonApp.CreateItem(olMailItem)
' Répertoire "Archive" et controle
Set MonDossierArchive = MonNomSpace.Folders("0").Folders("1").Folders("2").Folders("3")
If MonDossierArchive Is Nothing Then
MsgBox "Le dossier outlook archive est incorrect " & MonDossierArchive, vbQuestion
Exit Sub
End If
' Paramétrage du message
With MonMail
.To = xxxxxx@hotmail.fr
.BCC = BàL cachée optionnelle
.Subject = strEmailObj
.Body = strEmailMsg
' Joindre les pièces
.Attachments.Add (strDocPDF)
blnEdit = True
' Déplacement du mail dans le dossier archive
Set MonMail.SaveSentMessageFolder = MonDossierArchive
' Envoie du mail
.Send
End With
End Sub |
Partager