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
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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 ?
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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.
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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 ?
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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é ...
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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 ?
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bpnsoir,
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é.vlko a écrit :Cela souligne mes commentaires mais aussi les tableaux qui sont dans le corps du mail.
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.
- 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.
Ci-joint un fichier excel d'exemple avec les 2 macros.
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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
- Messages
- 4'092
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
ci-jointe nouvelle version en combinant les 2 codes (envoi_mail3)
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" :
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
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 !