Tables
Formulaires
Automation
Administration
Envoyer un mail
Outlook
Dates - Heures
Fichiers
Références
La normalisation
VBA
992117 visiteurs
3 visiteurs en ligne
Il suffit pour cela de placer un bouton sur un formulaire et dans la Sub de l'événement "Sur clic" de placer l'appel au code fourni ci-dessous.
Exemple de code pour le bouton:
SendReportHTML "Nom état", "toto@hotmail.com", "Objet", False
Au lieu de False comme dernier paramètre, on peut utiliser True ce qui permet d'éditer le message avant l'envoi.
Attention : Il faut utiliser le second code pour Access 2007 et plus
Code pour Access 2000 à 2003
Public Sub SendReportHTML(NomEtat As String, _ Destinataire As String, _ Sujet As String, _ EditMessage As Boolean, _ Optional PieceJointe As String) '/ Déclaration des variables Dim NbFichiers As Integer Dim i As Integer Dim LeFichier As String Dim txtLine As String Dim F As Integer Dim CorpsHTML As String Dim Ol_App As New Outlook.Application Dim Ol_Item As Outlook.MailItem ' DoCmd.Hourglass True ' With Application.FileSearch .LookIn = CurDir .SearchSubFolders = False .FileName = NomEtat & "*.htm" .Execute NbFichiers = .FoundFiles.Count LeFichier = CurDir & "/" & NomEtat & ".htm" DoCmd.OutputTo acOutputReport, NomEtat, acFormatHTML, LeFichier, False .Execute NbFichiers = .FoundFiles.Count - NbFichiers End With ' F = FreeFile For i = 1 To NbFichiers If i > 1 Then: LeFichier = CurDir & "/" & NomEtat & "Page" & i & ".htm" SysCmd acSysCmdInitMeter, "Intégration de " & LeFichier, NbFichiers SysCmd acSysCmdUpdateMeter, i Open LeFichier For Input As #F Do While Not EOF(F) Line Input #F, txtLine CorpsHTML = CorpsHTML & txtLine Loop Close #F Kill LeFichier Next i ' SysCmd acSysCmdClearStatus Set Ol_Item = Ol_App.CreateItem(olMailItem) '/ Création du message With Ol_Item .To = Destinataire .Subject = Sujet .HTMLBody = CorpsHTML If PieceJointe <> "" Then: .Attachments.Add PieceJointe .Save If EditMessage = True Then .Display Else .Send End If End With '/ Libération Set Ol_Item = Nothing Set Ol_App = Nothing DoCmd.Hourglass False End Sub
Public Sub SendReportHTML(NomEtat As String, _ Destinataire As String, _ Sujet As String, _ EditMessage As Boolean, _ Optional PieceJointe As String) '/ Déclaration des variables Dim NbFichiers As Integer Dim i As Integer Dim LeFichier As String Dim txtLine As String Dim F As Integer Dim CorpsHTML As String '/ Nécessite le référence Microsoft Outlook Dim Ol_App As New Outlook.Application Dim Ol_Nspace As Outlook.NameSpace Dim Ol_Item As Outlook.MailItem ' '/ Nécessite la référence Microsoft Scripting Runtime Dim FSO As Scripting.FileSystemObject Dim scrFolder As Scripting.Folder Dim fileItem As Scripting.File ' Set FSO = New Scripting.FileSystemObject Set scrFolder = FSO.GetFolder(CurDir) Set Ol_Nspace = Ol_App.GetNamespace("MAPI") ' DoCmd.Hourglass True ' With scrFolder.Files NbFichiers = .Count LeFichier = CurDir & "/" & NomEtat & ".htm" '/ Export de l'état au format HTML DoCmd.OutputTo acOutputReport, _ NomEtat, acFormatHTML, _ LeFichier, False NbFichiers = (.Count - NbFichiers) End With ' F = FreeFile For i = 1 To NbFichiers If i > 1 Then LeFichier = CurDir & "/" & NomEtat _ & "Page" & i & ".htm" End If '/ Affichage la progression dans la barre d'état SysCmd acSysCmdInitMeter, "Intégration de " _ & LeFichier, NbFichiers SysCmd acSysCmdUpdateMeter, i '/ Lire le contenu des fichiers HTML Open LeFichier For Input As #F Do While Not EOF(F) Line Input #F, txtLine CorpsHTML = CorpsHTML & txtLine Loop Close #F Kill LeFichier Next i ' SysCmd acSysCmdClearStatus Set Ol_Item = Ol_App.CreateItem(olMailItem) '/ Si Outlook non démarré If Not Ol_Nspace Is Nothing Then Ol_Nspace.Logon , , True, False End If '/ Construction du message With Ol_Item .To = Destinataire .Subject = Sujet .HTMLBody = CorpsHTML If PieceJointe <> "" Then .Attachments.Add PieceJointe End If .Save If EditMessage = True Then .Display Else .Send End If End With '/ Libération Ol_Nspace.Logoff Set Ol_Item = Nothing Set Ol_App = Nothing Set FSO = Nothing Set scrFolder = Nothing DoCmd.Hourglass False End Sub