Envoyer tableau par mail, dans le corps du texte, plusieurs destinataires

Le 10/03/2021 à 12:20

Bonjour à tous,

Pouvez-vous m’aider sur ce sujet ?

J’envoie des mails, tous les jours à mes contacts (nommés affiliés), avec des informations qui les concernent, Ces informations sont contenues dans un tableau.

Je souhaite créer une macro qui génère ce mail, pour chacun d’entre eux, en regroupant les lignes de la colonne « J », qui les concernent.

Chaque affilié a un code :

capture affile

Autrement dit, pour chaque affilié un mail regroupant ses informations.

La complexité vient du fait que je souhaite insérer ce tableau dans le corps du texte.

Je joins mon fichier à ma demande, pour une meilleure compréhension.

  • En feuille 1 mon tableau
  • En feuille 2 (Contact ) les adresses mails de chaque affilié.
  • En feuille 3 le corps de mon texte

Ci-dessous l'exemple du mail:

capture mail

Je vous remercie de l’aide que vous pourrez m’apporter sur ce sujet

Cordialement,

Kensy

88macro-filtrage-des-affillies-copie.xlsm (36.35 Ko)
Le 10/03/2021 à 20:41

Bonjour Kensy,

J'ai adapté le code que j'ai proposé sur un autre forum il y a quelques jours, voois si cela te convient:

Sub mailSeq()
    'https://forum.excel-pratique.com/excel/envoyer-tableau-par-mail-dans-le-corps-du-texte-plusieurs-destinataires-154295

    Dim Wks    As Worksheet, WksCont As Worksheet
    Dim OutMail As Object
    Dim OutApp As Object
    Dim myRng  As Range
    Dim list   As Object
    Dim item   As Variant
    Dim LastRow As Long, LastRowCont As Long
    Dim uniquesArray()
    Dim Dest   As String
    Dim strbody As String

    Set list = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Feuil1")
    Set WksCont = ThisWorkbook.Sheets("Contact")
    LastRowCont = WksCont.Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    With Wks
        .Activate
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        For Each item In .Range("J2", .Range("J" & .Rows.Count).End(xlUp))
            If Not list.Contains(item.Value) Then list.Add item.Value
        Next
    End With

    For Each item In list

        Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=10, Criteria1:=item
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next

        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A1:J" & LastRow).SpecialCells(xlCellTypeVisible)

        Dest = Application.WorksheetFunction.VLookup(Cells(LastRow, "J").Value, WksCont.Range("A1:B" & LastRowCont).Value, 2, False)

        strbody = "Bonjour à tous, " & "<br>" & _
                  "Veuillez trouver ci-dessous vos suspens SLAB." & "<br>" & _
                  "Nous vous remercions de vous placer sur nos relances." & "<br/><br>"

        With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Deals"
            .HTMLBody = strbody & RangetoHTML(myRng) & "<br>" & "Cordialement"
            .Display
            '.Send
        End With
        On Error GoTo 0
    Next

    On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0

    Application.ScreenUpdating = True

End Sub
Function RangetoHTML(myRng As Range)

    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0

        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                  "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Le 10/03/2021 à 22:39

Bonsoir,

ci-jointe proposition

168macro-filtrage-des-affillies1.xlsm (42.54 Ko)
Le 11/03/2021 à 09:37

Bonjour à vous deux,

Tout d’abord un grand merci. Franchement, bravos !

Nous approchons du but.

@Thev, ta proposition est la plus proche, mais pour une raison qui m'échappe, ma signature automatique se retrouve en haut de page.

signature en haut

@Sequoyah, ton code fonctionne, cependant, il prend des adresses mails, pour certains affiliés qui ne sont pas concernés par l'information.

non concerne

Pour finir, je souhaite que le code nous alerte sur un affilié qui est dans le tableau, mais qui ne figure pas dans la liste des destinataires.

Par exemple, le 499 est présent dans le tableau, mais absent de la liste des contacts.

499

Merci beaucoup pour votre aide.

Cordialement,

Kensy

Le 11/03/2021 à 11:09

Bonjour,

Correction de la position de la signature. Version à suivre pour alerte sur affilié non dans la liste des destinataires

97macro-filtrage-des-affillies2.xlsm (42.40 Ko)
Le 11/03/2021 à 14:38

Bonjour,

ci-jointe version avec alerte sur les affiliés absents dans les contacts

53macro-filtrage-des-affillies3.xlsm (46.65 Ko)
Le 11/03/2021 à 15:53

Impeccable!

Merci Thev.

je mets une version du fichier sans la gestion de la signature, pour ceux que çaintéresse.

60copie-de-macro-filtrage-des-affillies3-1.xlsm (42.56 Ko)
Le 12/03/2021 à 19:47

Bonsoir,

A la demande de KensyStyle, ci-jointe une version gérant mieux la signature automatique si elle est présente.

149macro-filtrage-des-affillies4.xlsm (46.31 Ko)
Le 14/03/2021 à 22:30

Bonsoir Thev,

Merci pour les modifications.

j'ai tenté d'insérer une ligne de code afin de changer l'adresse mail de l'expéditeur.

Je souhaite renseigner celle de mon service, mais cela envoie quand même les mails depuis ma boite personnelle.

Avez vous une solution pour ce problème ?

depuis adesse opcvm

Cordialement,

Kensy

Le 15/03/2021 à 18:53

Bonsoir,

Ce qui est possible, c'est de changer le compte de messagerie émetteur s'il est répertorié dans l'application Outlook. A noter que la signature changera car elle est associée au compte. Ci-dessous code

Sub envoi_mail(ByVal affilié As String, ByVal Destinataire As String, ByVal plage As Range)
    Dim signature As String

    ' On définit les variables
    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object, compte_messagerie As Object

    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(olMailItem)
    Set wDoc = myItem.GetInspector.WordEditor
    Set rng = wDoc.Content

    With myItem
        ' On prépare le mail en rentrant les paramètres : adresse des destinataires, en copie, objet du mail, corps du mail
        .To = Destinataire
        .Subject = "Suspens SLAB affilié " & affilié
        For Each compte_messagerie In OL.Session.Accounts
            If compte_messagerie.UserName = "expéditeur@gmail.com" Then
                Set .SendUsingAccount = compte_messagerie
                Exit For
            End If
        Next compte_messagerie

        .Display

        ' Stockage de la signature automatique  et effacement
        signature = rng.Text: rng.Delete

        .................................................
Le 16/03/2021 à 09:28

Bonjour Thev,

Ça ne fonctionne pas, cela prend toujours mon adresse mail.

Si ça peut vous aider, vous trouverez un exemple qui fonctionne dans le module 1 de mon fichier.

Cordialement,

Kensy

Le 16/03/2021 à 09:49

Bonjour,

Si ça ne fonctionne pas, c'est que le compte que vous voulez utiliser, ne figure pas dans votre session Outlook.

Pour voir les comptes y figurant, dans votre application Outlook : menu Accueil --> nouveau Courrier --> cliquer sur "De"

Comme il s'agit d'un envoi via l'éditeur Word, le .SentOnBehalfOfName ne fonctionne pas. Je regarde l'envoi sans l'éditeur Word.

Le 16/03/2021 à 18:46

Bonsoir,

ci-dessous version sans l'éditeur Word

Sub envoi_mail(ByVal affilié As String, ByVal Destinataire As String, ByVal plage As Range)

    ' On définit les variables
    Dim OL As Object, myItem As Object

    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(olMailItem)

    With myItem
        ' Destinataire, Expéditeur, objet du mail
        .To = Destinataire
        .SentOnBehalfOfName = "xxxx@yyyyy.com"
        .Subject = "Suspens SLAB affilié " & affilié

        ' Corps du mail
        .HTMLBody = PlageToHtml(Range("corps_mail"))

        ' Copie de la plage
        .HTMLBody = .HTMLBody & PlageToHtml(plage)

        ' Formule de politesse
        .HTMLBody = .HTMLBody & "<br/>" & "<br>" & "Cordialement"

        'Affectation de la signature
        .HTMLBody = .HTMLBody & "<br/>" & "<br>" & Signature("ssss")

        ' Envoi mail
        .Send

    End With

    Set OL = Nothing

End Sub

ci-dessous les 2 fonctions à ajouter

Function PlageToHtml(plage As Range)

    Dim fic_html As String
    Dim no_fichier, erreur As Integer

    ' contrôle variable
    If Not IsObject(plage) Then Exit Function
    If Not plage.Count > 0 Then Exit Function

    ' création fichier HTML
    fic_html = ThisWorkbook.Path & "\corps_mail.htm"
    With ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=fic_html, Sheet:=plage.Worksheet.Name, Source:=plage.Address)
        .Publish (True)
    End With

    ' récupération contenu fichier HTML
    no_fichier = FreeFile()
    Open fic_html For Binary Access Read As #no_fichier
    PlageToHtml = Input$(LOF(no_fichier), no_fichier)
    Close #no_fichier

    ' suppression fichier HTML
    Kill fic_html

    ' alignement à gauche
    PlageToHtml = Replace(PlageToHtml, "align=center", "align=left")

End Function

Function Signature(nom_signature As String) As String
    Dim FSO As Object, TextStream As Object
    Dim nom_fichier As String

    Signature = Empty
    On Error Resume Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
    nom_fichier = Environ("APPDATA") & "\Microsoft\Signatures\" & nom_signature & ".htm"
    Set TextStream = FSO.OpenTextFile(nom_fichier)
    If Err.Num = 0 Then
        Signature = TextStream.ReadAll
        'remplacement adresse relative images par adresse absolue
        Signature = Replace(Signature, nom_signature & "_files/", Environ("APPDATA") & "\Microsoft\Signatures\" & nom_signature & "_files/")
    End If
End Function
Rechercher des sujets similaires à "envoyer tableau mail corps texte destinataires"