VBA, envoyer un mail depuis excel en compilant plusieurs sources (tableaux, graphiques, texte)

Version imprimable

2 pièce(s) jointe(s)

Bonjour à tous,

Je cherche un petit peu d'aide pour envoyer des mails depuis Excel à l'aide de VBA.
Plusieurs post parlent déjà de ce sujet et m'ont permis de reprendre la base de code ci-dessous qui fonctionne pour envoyer un seul tableau dans le corps du message, sans texte ni commentaire. (voir résultat capture ci-jointe)

Mon problème est que je n'arrive pas à créer un corps de message avec plusieurs éléments.
En sommes, je voudrais créer un mail du type :

Bonjour,
bla,blabla, ....
[graphique]

bla,bla,bla
[Tableau1]

bla,bal,bla
[tableau 2]

...
[Tableau 5]

bla,bla
Cordialement
Signature

L'ensemble des tableau et graphiques sont à copier coller depuis le Excel.

Voila le code actuel
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub mailling() 'ThisWorkbook.RefreshAll Set OOutlook = CreateObject("Outlook.Application") Set OMail = OOutlook.CreateItem(olMailItem) With OMail .To = Sheets("Param mails").Range("D2").Value ' Destinataire .CC = Sheets("Param mails").Range("E2").Value ' en copie à .Subject = "Traçabilité produit - " & Sheets("Tab mail hebdo").Range("B2").Value & " - SL" & Right(Sheets("Tab mail hebdo").Range("C2").Value, 2) .Body = "Bonjour" & vbLf & Sheets("Tab mail hebdo").Range("A5:F5").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Set OTexte = OMail.GetInspector.WordEditor OTexte.Range.Paste .Display End With End Sub
Le premier point qui m'agace c'est que le .Body="Bonjour" & vbLf & copier-coller d'un tableau ne renvois pas bonjour puis à la ligne tableau mais seulement le tableau.

De même lorsque je fais un .Body= copier-coller du tableau suivi de .Body= "Bonjour" & vbLf & .Body, j'obtiens :

Bonjour
-1

Il y a clairement des choses qui m'échappent et j'espère ne pas faire doublon avec un post existant que je n'aurais pas trouvé mais la je patauge ...

Merci d'avance à ceux qui auront quelques lumières pour moi :D

24/08/2017, 16h04
elea74

Flute, zut !!

Je viens de réaliser que je n'ai pas tout à fait posté mon message au bon endroit mais je ne trouve pas comment le déplacer dans la section VBA du forum Excel ...:boulet:

C'est possible de le déplacer ? ou il faut que je le clôture et que je le ré-ouvre ?

Bonjour,

tu peux t'aider de la propriété HTMLBody pour utiliser une plage excel dans ton email

voici une adaptation de ta procédure, en liaison tardive (pour éviter d'avoir à cocher la référence Outlook dans ton projet)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Sub mailling()
 Dim OOutlook As Object
 Set OOutlook = CreateObject("Outlook.Application")
With OOutlook.CreateItem(0)
       .To = Sheets("Param mails").Range("D2").Value  ' Destinataire
       .CC = Sheets("Param mails").Range("E2").Value  ' en copie à
       .Subject = "Traçabilité produit - " & Sheets("Tab mail hebdo").Range("B2").Value & " - SL" & Right(Sheets("Tab mail hebdo").Range("C2").Value, 2)
       .HTMLBody = "Bonjour" & vbCrLf & vbCrLf & RangetoHTML(Sheets("Tab mail hebdo").Range("A5:F5"))
       .Display
End With
 Set OOutlook = Nothing
End Sub

Et la fonction qui converti ta plage en HTML (à placer dans un module standard)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Function RangetoHTML(ByVal Rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
 
        .Cells(1).PasteSpecial Paste:=12
        .Cells(1).PasteSpecial Paste:=-4122
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        .Columns.AutoFit
        '.Rows.AutoFit
        On Error GoTo 0
    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

Wouhaa !!!

Merci pour cette super réponse écrite en moins de temps qu'il ne m'en faut pour la lire et surtout la décodée :roll:

Pour ceux qui pourraient avoir le même besoin que moi, j'ai ajouter ".currentRegion" pour faire la sélection complète du tableau quelque soit le nombre de lignes (je l'écris car il m'a fallu pratiquement 2h pour trouver comment le faire donc si ca peut aider ...).
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub mailling() Dim OOutlook As Object 'ThisWorkbook.RefreshAll Set OOutlook = CreateObject("Outlook.Application") With OOutlook.CreateItem(olMailItem) .To = Sheets("Param mails").Range("D2").Value ' Destinataire .CC = Sheets("Param mails").Range("E2").Value ' en copie à .Subject = "Traçabilité produit - " & _ Sheets("Tab mail hebdo").Range("B2").Value & _ " - SL" & _ Right(Sheets("Tab mail hebdo").Range("C2").Value, 2) 'Objet du mail .HTMLBody = "Bonjour" & vbLf & RangetoHTML(Sheets("Tab mail hebdo").Range("A5:F5").CurrentRegion) .Display End With End Sub

25/08/2017, 11h26
halaster08
Citation:
Envoyé par elea74

Le petit hic c'est que mes tableaux sont à dimensions variable (le nombre de ligne est dynamique), c'est pour cela que j'utilisais la méthode suivante (probablement pas la plus performante mais fonctionnelle)

Code:

1 2 3 Sheets("Tab mail hebdo").Range("A5:F5").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy

Dans cette nouvelle solution, j'ai compris que la fonction crée "RangetoHTLM" (dont j'ai globalement compris le fonctionnement mais que je n'aurais pas su écrire) attendait la totalité du tableau soit A5 à Fxxx. Après plusieurs essais infructueux je n'ai pas trouvé comment rédiger correctement pour que le programme me comprenne.

Toute suggestion est la bienvenue :)
Bonjour,

Comme ceci:

Code:

RangetoHTML(Sheets("Tab mail hebdo").Range(Sheets("Tab mail hebdo").Range("A5:F5"), Sheets("Tab mail hebdo").Range("A5:F5").End(xlDown)))
25/08/2017, 16h28
elea74

J'y suis presque !
Youpi, youpla,
Grace à vos précieux conseils je suis proche du résultat final souhaité, il me manque un dernier point qui est comment ajouter un graphique dans mon mail dans le .HTMLBody?

J'ai naïvement (et sans conviction) tenté le

Code:

RangetoHTML(Sheets("Graph PF").ChartObjects ("PRESTA")

mais comme présumé c'est pas vraiment fait pour.

D'autres tentatives plus ou moins farfelues ne m'on pas donné grand résultats, je m'en remet donc à vous.

PS : Pour les néophytes comme moi qui auraient le même besoin que moi, pour ajouter un contenu selon des conditions, il faut faire le si en dehors du .HTMLBody de la manière suivante :
Code:

1 2 3 4 5 6 .HTMLBody = "Début du corps du message" if condition then .HTMLBody = .HTMLBody + "message si condition vraie" else .HTMLBody = .HTMLBody + "message si condition fausse" Endif
PPS : Toujours pour les néophytes, pour faire un retour à la ligne ou toute autre mise en forme, il faut utiliser les balises HTLM à l'intérieur des guillemets, par exemple :

Code:

.HTMLBody = "Début du corps du message la balise br fait un retour à la ligne lors de l'exécution du code"
29/08/2017, 16h38
elea74

Bonjour à tous,

Je remercie vivement les personnes m'ayant déjà aidé.
Je remet juste un tout petit message, car je cherche toujours comment ajouter un graphique dans le .HTLMbody de mon mail.

Au cas où quelqu'un aurait une astuce :D
30/08/2017, 09h54
1357VBA

idée... d'un néophite

Citation:

Envoyé par elea74

Bonjour à tous,

Je remercie vivement les personnes m'ayant déjà aidé.
Je remet juste un tout petit message, car je cherche toujours comment ajouter un graphique dans le .HTLMbody de mon mail.

Au cas où quelqu'un aurait une astuce :D

Bonjour,

Est-il possible de transformer un graphique en jpeg ou autre fichier image ?
Si oui, il est peut-être plus aisé d'intégrer cette image à ton html.

Quelqu'un m'a écrit ici qu'il fallait que je pense Excel avant de penser VBA...

enregistrement image

Bonjour,

J'avais fais un truc pour enregistrer une plage spécifique en JPEG pour l'inculre dans un mail.

Je pense que tu peux adapter pour un graphique :
Code:

1 2 3 4 5 6 7 8 Sheets("roulement et info mécanicien").Select Range("A1:Q28").CopyPicture Workbooks.Add ActiveSheet.Paste With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart .Paste .Export "C:\Temp\Downloaded filesExcelPicture 1.jpg", "JPG" End With
Et ensuite dans les paramètre de l'email,tu rajoute de l'HTML,et tu peux inclure ton image en HTML :

Code:

.HTMLBody = "" & ActiveWorkbook.Sheets("donee_générale").Range("CM8").Value & """ ""<img src='C:\Temp\Downloaded filesExcelPicture 1.jpg'>"

Ajout graphique dans .HTMLbody, ma solution inspirée de vos propositions

Bonjour à tous,

Ca y est ça marche !

Bon avant de clôturer, voila ce que j'ai fait en passant pas une image, si ca peut aider un potentiel lecteur :
Code:

1 2 3 4 5 6 7 8 'export graphique format image Sheets("Graphs").ChartObjects("NomDuGraph").Chart.Export Filename:="C:\Temp\NomDuGraph.png", FilterName:="png" 'ajout du graphique dans le corps du mail (à placer au bon endroit par rapport aux autres éléments du mail) .HTMLbody = .HTMLbody + "<img src='C:\Temp\NomDuGraph.png'>" 'suppression de l'image créé enregistrée sur le PC kill "C:\Temp\NomDuGrap.png"
Merci encore à tous pour vos lumières !:mrgreen:

1 pièce(s) jointe(s)

Probleme avec fonction RangetoHTML

Citation:

Envoyé par joe.levrai

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Sub mailling()
 Dim OOutlook As Object
 Set OOutlook = CreateObject("Outlook.Application")
With OOutlook.CreateItem(0)
       .To = Sheets("Param mails").Range("D2").Value  ' Destinataire
       .CC = Sheets("Param mails").Range("E2").Value  ' en copie à
       .Subject = "Traçabilité produit - " & Sheets("Tab mail hebdo").Range("B2").Value & " - SL" & Right(Sheets("Tab mail hebdo").Range("C2").Value, 2)
       .HTMLBody = "Bonjour" & vbCrLf & vbCrLf & RangetoHTML(Sheets("Tab mail hebdo").Range("A5:F5"))
       .Display
End With
 Set OOutlook = Nothing
End Sub

Et la fonction qui converti ta plage en HTML (à placer dans un module standard)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Function RangetoHTML(ByVal Rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
 
        .Cells(1).PasteSpecial Paste:=12
        .Cells(1).PasteSpecial Paste:=-4122
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        .Columns.AutoFit
        '.Rows.AutoFit
        On Error GoTo 0
    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

Bonjour Joe.levrai
J'ai utilisé votre fonction RangetoHTML qui correspond exactement à ce que je voulais faire.
Petit problème, je ne peux l'appliquer que sur 5 onglets.. à partir du 6e, la fonction mouline et fait planter Outlook.
Auriez-vous une astuce pour résoudre ce problème ?
Merci de votre aide,