Integrer un état

Intégrer un état Access dans le corps d'un message électronique

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

Code pour Access 2007 et plus

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