Insérer plages cellules corps mail Outlook collage spécial

Bonjour à tous,

J'aimerais réaliser une macro VBA qui, à partir d'un fichier Excel, permet de préparer un mail Outlook contenant plusieurs tableaux/ plages de cellules dans le corps du message.

Par exemple coller 2 tableaux différents copiés à partir d'une même feuille Excel "Test" et séparés par du texte dans le corps du mail.

Je sélectionne par exemple les deux tableaux Range("A1", "F10") et Range("J1", "N10") et de plus j'aimerais coller les tableaux avec un collage spécial "Image (métafichier amélioré)".

J'ai déjà réalisé un bout de code pour préparer le mail avec le titre, destinataires, cc... et ça marche.

Mais je bloque sur l'insertion des tableaux/plages de cellules avec le collage spécial.

Sub CollerMail()

    ' Définition des variables Outlook
    Dim OL As Object, myItem As Object
    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(olMailItem)

    ' On prépare le mail en rentrant les paramètres : adresse des destinataires, en copie, objet du mail, contenu du mail
    With myItem
        .To = "destinataire@gmail.com"
        .CC = "copiemail@gmail.com"
        .Subject = "Objet mail"
        .Body = ""
        .Display
    End With

    Set OL = Nothing

End Sub

Merci d'avance pour votre aide

Bonsoir,

ci-dessous proposition :

Sub envoi_mail()
    Dim olk As Object, email As Object, wdDoc As Object
    Dim erreur As Integer, nb_lignes As Integer
    Dim rng As Object

    On Error Resume Next    'désactivation routine d'erreur
     erreur = False

    'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
     Set olk = CreateObject("outlook.application")
    Set email = olk.CreateItem(olMailItem)
    Set wdDoc = email.GetInspector.WordEditor

    With email
        '....... remplissage sujet, objet, et adresse
         .To = "xxxxxxx@domaine"
        .CC = "yyyyyyy@domaine"
        .Subject = "test01"

        '....... corps du mail
        .Display
        With Sheets("Test")
            'premier tableau
             .Range("A1:F10").Copy
            nb_lignes = .Range("A1:F10").Rows.Count
            Set rng = wdDoc.Content
            rng.Paste

            'insertion texte
             rng.InsertAfter "ligne1" & vbCrLf
            nb_lignes = nb_lignes + 1
            rng.InsertAfter "ligne2" & vbCrLf
            nb_lignes = nb_lignes + 1

            'deuxième tableau
             .Range("J1:N10").Copy
            Set rng = rng.GoTo(What:=3, Which:=2, Count:=nb_lignes)
            rng.Paste
        End With

        '....... envoie le message
         .Send
        If Err.Number <> 0 Then erreur = True
    End With

    'Désassignation objets
     Set olk = Nothing
    Set email = Nothing
    Set wdDoc = Nothing
End Sub

Bonjour,

Merci pour ta réponse, l'idée est bonne.

J'ai essayé le code mais j'ai un message d'erreur, mon code bloque au niveau de GoTo.

J'ai essayé d'adapter ton code avec d'autres idées trouvées sur le net :

 Sub Macro1_3()

    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object

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

   Sheets("Test").Activate

    ' On prépare le mail en rentrant les paramètres : adresse des destinataires, en copie, objet du mail, contenu du mail
    With myItem
        .To = "xxx@domaine"
        .CC = "yyy@domaine"        
        .Subject = "subject"        .BodyFormat = olFormatHTML
        .Display

        ' Premier tableau
        Range("A1:F10").Copy
        Set rng = wDoc.Content
        rng.Paste

        ' Insertion texte premier tableau
        rng.InsertAfter "" & vbNewLine & "Commentaires" & vbCrLf
        rng.Move wdParagraph, 1

        ' Deuxième tableau
        Range("J1:N10").Copy
        rng.Paste

        ' Insertion texte deuxième tableau
        rng.Move wdParagraph, 1
        rng.InsertAfter "" & vbNewLine & "Commentaires 2" & vbCrLf
        rng.Move wdParagraph, 1

    End With

    Set OL = Nothing
    Set myItem = Nothing
    Set wDoc = Nothing

 End Sub

Le code insère bien les plages de cellules à la suite mais le problème est que les tableaux ne sont toujours pas sous format d'image.

Comment est-ce que je peux faire pour cela ?

Bonjour,

Je pense qu'il faut utiliser au lieu de "Paste" la méthode Word "PasteExcelTable" avec les paramètres appropriés.

EDIT : J'ai légèrement modifié le code afin que les tableaux soit coller en tant qu'image.

Sub Macro1_3()

    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object

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

   Sheets("Test").Activate

    ' On prépare le mail en rentrant les paramètres : adresse des destinataires, en copie, objet du mail, contenu du mail
    With myItem
        .To = "xxx@domaine"
        .CC = "yyy@domaine"        
        .Subject = "subject"        
        .BodyFormat = olFormatHTML
        .Display

        ' Premier tableau
        Range("A1:F10").Copy
        Set rng = wDoc.Content
        rng.PasteSpecial , DataType:=wdPasteMetafilePicture

        ' Insertion texte premier tableau
        rng.InsertAfter "" & vbNewLine & "Commentaires" & vbCrLf
        rng.Move wdParagraph, 1

        ' Deuxième tableau
        Range("J1:N10").Copy
        rng.PasteSpecial , DataType:=wdPasteMetafilePicture

        ' Insertion texte deuxième tableau
        rng.Move wdParagraph, 1
        rng.InsertAfter "" & vbNewLine & "Commentaires 2" & vbCrLf
        rng.Move wdParagraph, 1

    End With

    Set OL = Nothing
    Set myItem = Nothing
    Set wDoc = Nothing

 End Sub

Ca fonctionne c'est à dire que les tableaux sont collés en tant qu'image mais le problème est que mes tableaux ne se collent pas à la suite, ils sont l'un sur l'autre et recouvrent aussi les textes qui devraient séparer les deux tableaux à la suite.

Il faudrait pouvoir faire des sauts de ligne pour coller les tableaux.

Bonjour,

nouvelle proposition ci_jointe

Sub envoi_mail()
    Dim olk As Object, email As Object, wdDoc As Object
    Dim erreur As Integer, nb_lignes As Integer, i As Integer
    Dim rng As Object

    On Error Resume Next    'désactivation routine d'erreur
     erreur = False

    'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
     Set olk = CreateObject("outlook.application")
    Set email = olk.CreateItem(olMailItem)
    Set wdDoc = email.GetInspector.WordEditor

    With email
        '....... remplissage sujet, objet, et adresse
         .To = "xxxxxxx@gmail.com"
        .CC = "yyyyyyy@gmail.com"
        .Subject = "test01"

        '....... corps du mail
         .Display
        With Sheets("Test")
            'premier tableau
             .Range("A1:F10").Copy
            nb_lignes = .Range("A1:F10").Rows.Count
            Set rng = wdDoc.Content
            rng.PasteSpecial , DataType:=wdPasteMetafilePicture
            For i = 1 To nb_lignes: rng.InsertParagraphAfter: Next i

            ' Insertion texte premier tableau
             rng.InsertAfter vbNewLine & "Commentaires" & vbCrLf
            rng.InsertAfter vbNewLine 
            rng.Move wdParagraph

            ' Deuxième tableau
             .Range("J1:N10").Copy
            nb_lignes = .Range("J1:N10").Rows.Count
            rng.PasteSpecial , DataType:=wdPasteMetafilePicture
            For i = 1 To nb_lignes: rng.InsertParagraphAfter: Next i

            ' Insertion texte deuxième tableau
             rng.InsertAfter "" & vbNewLine & "Commentaires 2" & vbCrLf
        End With

        '....... envoie le message
         .Send
        If Err.Number <> 0 Then erreur = True
     End With

    'Désassignation objets
      Set olk = Nothing
     Set email = Nothing
     Set wdDoc = Nothing

End Sub

Hello,

Merci je vais essayer ta nouvelle proposition, elle a l'air de faire le saut de paragraphe que je recherche.

J'ai aussi cherché une autre solution de mon côté et j'ai fait le code suivant :

 Sub envoi_mail()

    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim nb_lignes As Integer

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

    Sheets("Test").Activate

    ' On prépare le mail en rentrant les paramètres : adresse des destinataires, en copie, objet du mail, corps du mail
    With myItem
        .To = "xxx@gmail.com"
        .CC = "yyy@gmail.com"
        .Subject = "test"
        .BodyFormat = olFormatHTML
        .Display

        Set wDoc = myItem.GetInspector.WordEditor

        ' Premier tableau
        Range("A1:F10").CopyPicture
        wDoc.Application.Selection.Paste

        ' Texte premier tableau
        Set rng = wDoc.Content
        rng.InsertAfter "" & vbNewLine & "Commentaires" & vbNewLine 

        ' Deuxieme tableau
        Range("J1:N10").CopyPicture
        wDoc.Application.Selection.Start = Len(.Body)
        wDoc.Application.Selection.End = wDoc.Application.Selection.Start
        wDoc.Application.Selection.Paste

    End With

    Set OL = Nothing
    Set myItem = Nothing
    Set wDoc = Nothing

 End Sub

Ce code fonctionne, mes tableaux sont bien collés en tant qu'image à la suite et sont séparés par du texte.

J'aimerais maintenant avec du html changer la police, la couleur et la taille de mon texte.

Le problème est que après InsertAfter, les balises html ne fonctionnent pas. J'ai testé ce code mais le format html ne marche pas.

rng.InsertAfter "" & vbNewLine &  "<P STYLE='font-family:Calibri;font-size:11pt;color:rgb(31,73,125)'>Commentaires</P>" & vbNewLine

De manière générale, comment intégrer du html pour modifier le format du texte dans ce cas, après InsertAfter ?

bonjour,

Pas besoin de HTML. Les fonctionnalités Word suffisent.

            ' Insertion texte premier tableau
            rng.InsertAfter vbNewLine & "Commentaires" & vbCrLf
            With rng.Font
                .Name = "Calibri"
                .Size = 11
                .ColorIndex = 6
            End With
            rng.InsertAfter vbNewLine
            rng.Move wdParagraph

Merci beaucoup ça marche parfaitement !

Avec les fonctionnalités Word, le format s'applique pour tous mes textes, comment faire si je souhaite par exemple sous-ligner uniquement une partie de mon texte ?

Je sais que je dois coder :

rng.Font.Underline = True

Mais cela sous-ligne tous mes commentaires, j'aimerais par exemple avoir le rendu suivant :

Commentaires :

- premier commentaire non sous-ligné ...

vlko a écrit :

Je sais que je dois coder :

rng.Font.Underline = True

Pas tout à fait

rng.Font.Underline = xlUnderlineStyleSingle

et cela ne souligne que le 2ème commentaire.

Hello

Merci ! J'ai mis ta proposition à la suite de mon code :

' Insertion texte premier tableau
            rng.InsertAfter vbNewLine & "Commentaires" & vbCrLf
            With rng.Font
                .Name = "Calibri"
                .Size = 11
                .ColorIndex = 6
                .Underline = xlUnderlineStyleSingle
            End With
            rng.InsertAfter vbNewLine
            rng.Move wdParagraph

Cela souligne mes commentaires mais aussi les tableaux qui sont dans le corps du mail.

Comment est-ce que je peux uniquement souligner une partie du texte qui sépare les tableaux sans aussi souligner les tableaux de données ?

Enfin j'ai une dernière question, il peut arriver qu'en générant le mail une signature automatique soit présente.

Ainsi lorsque je lance ma macro, les tableaux sont bien collés à la suite mais la signature générée se retrouve en plein milieu.

Comment gérer la signature automatique et la placer tout en bas du mail ?

Bpnsoir,

vlko a écrit :

Cela souligne mes commentaires mais aussi les tableaux qui sont dans le corps du mail.

Si vous collez des images, je ne vois pas comment vous pouvez avoir ce problème. En tout cas, dans ma version, le 2ème commentaire n'est pas souligné.

Pour ce qui concerne la signature automatique, essayer cette nouvelle version du code :

Sub envoi_mail()
    Dim olk As Object, email As Object, wdDoc As Object
    Dim erreur As Integer, nb_lignes As Integer, i As Integer
    Dim rng As Object

    On Error Resume Next    'désactivation routine d'erreur
     erreur = False

    'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
     Set olk = CreateObject("outlook.application")
    Set email = olk.CreateItem(olMailItem)
    Set wdDoc = email.GetInspector.WordEditor

    With email
        '....... remplissage sujet, objet, et adresse
         .To = "xxxxxxx@gmail.com"
        .CC = "yyyyyyy@gmail.com"
        .Subject = "test01"

        '....... corps du mail
         .Display
        With Sheets("Test")
            'premier tableau
             .Range("A1:F10").Copy
            nb_lignes = .Range("A1:F10").Rows.Count
            Set rng = wdDoc.Content
            For i = 1 To nb_lignes: rng.InsertParagraphBefore: Next i
            rng.Move wdParagraph, -nb_lignes
            rng.PasteSpecial , DataType:=wdPasteMetafilePicture
            rng.Move wdParagraph, nb_lignes

            ' Insertion texte premier tableau
             rng.InsertAfter vbNewLine & "Commentaires" & vbCrLf
            With rng.Font
                .Name = "Calibri"
                .Size = 11
                .ColorIndex = 6
                .Underline = xlUnderlineStyleSingle
            End With
            rng.InsertAfter vbNewLine
            rng.Move wdParagraph

            ' Deuxième tableau
             .Range("J1:N10").Copy
            nb_lignes = .Range("J1:N10").Rows.Count
            rng.PasteSpecial , DataType:=wdPasteMetafilePicture
            For i = 1 To nb_lignes: rng.InsertParagraphAfter: Next i

            ' Insertion texte deuxième tableau
             rng.InsertAfter "" & vbNewLine & "Commentaires 2" & vbCrLf
        End With

        '....... envoie le message
        .Send
        If Err.Number <> 0 Then erreur = True
    End With

    'Désassignation objets
      Set olk = Nothing
     Set email = Nothing
     Set wdDoc = Nothing

End Sub

Hello

Désolé de répondre aussi tard, j'étais assez occupé. J'ai donc testé les deux versions de code, la tienne et la mienne.

Je rencontre encore quelques problèmes avec les deux versions de code :

- Dans ton code "envoi_mail_2", les tableaux s'affichent bien et sont bien séparés par les textes. La signature auto se retrouve bien à la fin du mail aussi. Mais comment adapter le code avec un troisième tableau ? En effet, j'aimerais insérer un 3ème tableau à la suite du texte du deuxième tableau.

sans titre 2

- Dans ma version "envoi_mail", les tableaux s'affichent bien et sont bien séparer par les textes mais la signature auto se retrouve en plein milieu du mail, j'aimerais pouvoir placer la signature à la fin du mail avec ma version de code et gérer le soulignage.

sans titre

Ci-joint un fichier excel d'exemple avec les 2 macros.

146testmail.xlsm (25.25 Ko)

Bonjour,

Pas de souci pour ajouter le 3ème tableau avec mon code.

278testmail1.xlsm (24.59 Ko)

Super ! merci ça marche nickel !

J'ai repris ton code pour un autre fichier et sur d'autres tableaux mais j'observe que la taille des tableaux dans le mail est réduite et il y a trop d'espace entre les tableaux et les textes, est-ce que tu sais d'où peut venir le problème ?

Dans ce cas, est-ce que tu sais comment agrandir le tableau dans le mail avec la taille que je veux, dans le code ?

Est-ce que tu saurais aussi à partir de mon code "envoi_mail", comment est-ce je peux gérer la signature auto et la placer à la fin du mail ? Comme ce que tu as fais avec ton code en faite mais en adaptant à ma version...

Je continue à travailler mon code car avec celui-ci je n'ai pas de problème de taille ni d'espace mais juste le problème de signature.

Enfin dernier point, j'aimerais dans le texte du mail insérer des puces à la suite des commentaires avec le texte associé. J'ai cherché mais je ne trouve pas de solutions, est-ce que tu as une idée de comment faire ?

Merci

ci-jointe nouvelle version en combinant les 2 codes (envoi_mail3)

380testmail2.xlsm (24.30 Ko)

Salut !

Merci cette version marche très bien et c'est la plus aboutie jusqu'à présent

Dernier point, j'ai repris ce code sur un autre fichier et sur d'autres tableaux. (je ne peux malheureusement pas joindre ce fichier car c'est un fichier de travail)

Le code fonctionne c'est à dire que les tableaux s'affichent bien à la suite des autres et sont séparés par les textes et la signature se trouve à la fin du mail. Mon seul problème est que la taille des tableaux dans le mail est réduite.

Cependant si je remplace la ligne de copie dans ta version de code "rng.Paste" par celle de mon ancienne version de code

wDoc.Application.Selection.Paste

J'arrive à obtenir la bonne taille des tableaux, mais les tableaux ne s'affichent plus l'un en dessous de l'autre et séparés par les textes.

J'obtiens par exemple sur le fichier test avec le code "envoi_mail_4" :

sans titre 3

Aurais-tu une idée afin d'adapter ton code en utilisant "wDoc.Application.Selection.Paste" pour la copie et en gardant la forme de mail que je souhaite ?

Merci

259testmail2.xlsm (25.82 Ko)

Hello,

J'ai finalement réglé mon problème, j'arrive à obtenir la bonne taille pour mes tableaux qui sont bien séparés par les textes et avec la signature auto qui se trouve à la fin du mail

En cherchant de mon côté j'ai trouvé une autre solution et j'ai utilisé l'objet suivant dans mon code :

Set objSel = wDoc.Windows(1).Selection

En tout cas, je te remercie beaucoup pour ton aide !

Rechercher des sujets similaires à "inserer plages corps mail outlook collage special"