Integrer un état - CDO

Intégrer un état Access dans le corps d'un message électronique et l'envoyer par CDO

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:

SendReport_CDO "Mon état", "toto@free.fr", "riri@hotmail.com", "Objet", , "smtp.free.fr"

La fonction : 

Function SendReport_CDO(NomEtat As String, Emetteur As String, _
                        Destinataire As String, Sujet As String, _
                        Optional FichierJoint As String = "", _
                        Optional SMTP As String = "")

    '/ Déclaration des variables
    Dim NbFichiers As Integer
    Dim i As Integer
    Dim FichierHtml As String
    Dim txtLine As String
    Dim FF As Integer
    Dim CorpsHTML As String
    '/ Nécessite la référence
    '/ Microsoft CDO for Windows 2000 Library
    Dim config As CDO.Configuration
    Dim email As CDO.Message
    '/ 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)

    '/ Export de l'état au format HTML
    With scrFolder.Files
        NbFichiers = .Count
        FichierHtml = CurDir & "\" & NomEtat & ".htm"
        DoCmd.OutputTo acOutputReport, NomEtat, acFormatHTML, _
                       FichierHtml, False
        DoEvents: DoEvents
        NbFichiers = (.Count - NbFichiers)
    End With

    '/ Assemblage du corps du message HTML
    FF = FreeFile
    For i = 1 To NbFichiers
        If i > 1 Then
            FichierHtml = CurDir & "\" & NomEtat & "Page" & i & ".htm"
        End If
        Open FichierHtml For Input As #FF
        Do While Not EOF(FF)
            Line Input #FF, txtLine
            CorpsHTML = CorpsHTML & txtLine
        Loop
        Close #FF
        DoEvents: DoEvents
        Kill FichierHtml
    Next i
    '/
    '/ Configuration
    '/
    If SMTP = "" Then SMTP = "smtp.free.fr"
    Set config = New CDO.Configuration

    With config.Fields
        .Item("http://schemas.microsoft.com/cdo/" _
              & "configuration/sendusing") = CDO.cdoSendUsingPort
        .Item("http://schemas.microsoft.com/cdo/" _
              & "configuration/smtpserver") = SMTP
        .Update
    End With
    Set email = New CDO.Message

    '/ Construction et envoi du message
    With email
        Set .Configuration = config
        .From = Emetteur
        .To = Destinataire
        .Subject = Sujet
        .Textbody = "Ce message est au format HTML"
        .HTMLBody = CorpsHTML

        If FichierJoint <> "" Then
            .AddAttachment FichierJoint
        End If

        .Send

    End With

End Function