Copie de graphique Excel dans Outlook - Script qui fonctionne mais petite question :)

Version imprimable

Bonjour,

J'ai besoin de copier les graphiques d'un document Excel dans un nouveau mail Outlook.
Dans le but d'automatiser l'envoi de tableau de bord.

J'ai réussi un trouver un script qui fonctionne.

Le seul problème rencontré c'est que je n'arrive pas à modifier la taille des images qui sont copiées dans le corps du mail. (C'est très petit, du coup manip manuelle nécessaire :( )

Je bloque sur le réglage lié à la commande du script : objMailDocument.Range(0, 0)
Je n'arrive pas à trouver une méthode qui me donne la longueur et la largeur de l'image copiée dans le mail…

Voici le script complet que j'ai adapté pour mon besoin :
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 Sub CopyAllChartsToOutlookEmail() Dim objOutlookApp As Outlook.Application Dim objMail As Outlook.MailItem Dim objMailDocument As Word.Document Dim objSheet As Excel.Worksheet Dim objChart As Excel.ChartObject 'Get Outlook Application On Error Resume Next Set objOutlookApp = GetObject(, "Outlook.Application") If objOutlookApp Is Nothing Then Set objOutlookApp = CreateObject("Outlook.Application") End If 'Create an Outlook Email Set objMail = objOutlookApp.CreateItem(olMailItem) objMail.Display Set objMailDocument = objMail.GetInspector.WordEditor ' 'Copy All Charts from Each Sheet to the New Email 'Script original ' For Each objSheet In ActiveWorkbook.Worksheets ' For Each objChart In objSheet.ChartObjects ' objChart.Copy ' objMailDocument.Range(0, 0).Paste ' Next ' Next 'Script modifié. For Each objSheet In ActiveWorkbook.Worksheets If objSheet.Name = "Feuil1" Then For Each objChart In objSheet.ChartObjects objChart.Copy objMailDocument.Range(0, 0).Paste Next End If Next End Sub
Merci pour votre aide.
Cdt,
Cédric

03/03/2020, 18h16
MarcelG

Bonsoir Cédric,

Bienvenu sur le Forum.

Si cela peut t'aider.
Consulte ce billet.

Personnellement, je préfère insérer dans le corps de texte une image issue d'une exportation depuis Excel.

Bonjour Marcel,

Merci pour ta réponse.

As tu la possibilité de rajouter à ton billet, le fichier Excel avec les macros ?
Je pourrais ainsi mieux comprendre comment tout ceci est imbriqué.

Sinon j'ai analysé ton code, mais n'étant pas un expert j'ai encore pas mal de lacune.
J'ai tout de même pu modifier la taille des images grâce à la propriétés ".InlineShapes" présent dans ton script.

J'ai aussi modifié légèrement mon code avec un corps de message en HTML, récupéré sur un autre forum.

Je rencontre encore deux problèmes :
- Les graphiques sont ajoutés l'un après les autres, ce qui inverse l'ordre d'affichage de mes graphiques.
- Le corps du mail ce retrouve lui aussi décalé vers le bas.

Est-il possible d'inverser l'ordre d'affichage des graphiques, en commençant par exemple avec le dernier présent dans ma feuille ?
exemple du code utilisé :
Code:

1 2 3 4 5 6 7 For Each objChart In objSheet.ChartObjects objChart.Copy objMailDocument.Range(0, 0).Paste objMailDocument.InlineShapes(1).Width = 1400 * 0.75 objMailDocument.InlineShapes(1).Height = 560 * 0.75 Next
Est-il possible de saisir un corps de texte au fur et à mesure du remplissage des graphiques ?
Par exemple j'affiche un texte du style :
- "Voici mon 1er graphique"
- Ici le graphique 1 est affiché.
- "Voici mon 2nd graphique"
- Ici le graphique 2 est affiché.
et ainsi de suite,
puis afficher la signature par défaut

Voici le code que j'utilise au complet avec les quelques modification réalisées.
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 Sub CopyAllChartsToOutlookEmail() Dim objOutlookApp As Outlook.Application Dim objMail As Outlook.MailItem Dim objMailDocument As Word.Document Dim objSheet As Excel.Worksheet Dim objChart As Excel.ChartObject 'Get Outlook Application On Error Resume Next Set objOutlookApp = GetObject(, "Outlook.Application") If objOutlookApp Is Nothing Then Set objOutlookApp = CreateObject("Outlook.Application") End If 'Create an Outlook Email Set objMail = objOutlookApp.CreateItem(olMailItem) With objMail .Display .Subject = "Test" .BodyFormat = olFormatHTML .HTMLBody = "<HTML><H2>Test corps du mail en HTML.</H2><BODY>Message ? saisir. </BODY></HTML>" End With Set objMailDocument = objMail.GetInspector.WordEditor For Each objSheet In ActiveWorkbook.Worksheets If objSheet.Name = "Feuil1" Then For Each objChart In objSheet.ChartObjects objChart.Copy objMailDocument.Range(0, 0).Paste objMailDocument.InlineShapes(1).Width = 1400 * 0.75 objMailDocument.InlineShapes(1).Height = 560 * 0.75 Next End If Next End Sub
Cdt,
Cédric

Bonjour,

J'ai trouvé un début de solution, ce n'est sans doute pas des plus optimisé mais j'arrive à afficher mes graphiques dans l'ordre désiré.

J'ai trouvé un moyen de sauvegarder, dans une nouvelle variable en tableau, les graphiques retrouvés par la boucle "boucle for each…"
Ensuite je réalise une boucle classique for i=3 to step -1 pour afficher les graphiques de fin en premier.
A la fin de la boucle j'affiche un texte qui s'ajoute au graphique existant en début de mail.

Il me reste encore à finir d'ajouter la liste des destinataires que je vais lire dans une champ Excel et essayer d'optimiser ce code.

Le nouveau code :

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
 
Sub CopyAllChartsToOutlookEmail()
    Dim objOutlookApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim objMailDocument As Word.Document
    Dim objSheet As Excel.Worksheet
    Dim objChart As Excel.ChartObject
    Dim objChartTableau(6) As Excel.ChartObject
    Dim i, j As Integer
    'Get Outlook Application
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    If objOutlookApp Is Nothing Then
       Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
 'Create an Outlook Email
 Set objMail = objOutlookApp.CreateItem(olMailItem)
 
 With objMail
    .Display
    .Subject = "Test"
 End With
 
Set objMailDocument = objMail.GetInspector.WordEditor
 
i = 1
For Each objSheet In ActiveWorkbook.Worksheets
    If objSheet.Name = "Feuil1" Then
        For Each objChart In objSheet.ChartObjects
            Set objChartTableau(i) = objChart
            i = i + 1
        Next
    End If
Next
For i = 3 To 1 Step -1
    Debug.Print i & " " & objChartTableau(i).Name
    objChartTableau(i).Copy
    objMailDocument.Range(0, 0).Paste
    objMailDocument.InlineShapes(1).Width = 1400 * 0.75
    objMailDocument.InlineShapes(1).Height = 560 * 0.75
Next i
objMailDocument.Range(0, 0) = vbCrLf & "Bonjour," & vbCrLf & "Voici les graphiques de la semaine S-1" & vbCrLf
 
End Sub

Cdt,
Cédric

Bonjour Cédric,

Mes excuses pour cette réponse tardive.

Si, comme je te le recommande, les graphiques sont nommés - avec rigueur - tu peux les copier directement.

Un exemple extrait de l'un de mes applicatifs
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 For Each graph In Array("répart", "évolution") 'copie du graphique dans le corps de message Worksheets("Lesdonnées " & graph).Shapes("Graph_" & graph).Copy 'Adapter AppActivate objet_mail & " - Message (HTML)" ' Active Outlook 'AppActivate objet_mail & " - Message" ' Active Outlook With wdDoc 'Image en en-tête du corps de texte d'Outlook, au-dessus de la signature éventuelle .Range(0, 0).PasteAndFormat Type:=wdChartPicture Application.CutCopyMode = False 'Image redimensionnée .InlineShapes(1).Width = 725 End With Next graph
Au demeurant
- Nous nous rejoignons sur le processus consistant à copier chaque graphique au Range(0,0) de l'éditeur d'Outlook
- Tu as très bien su gérer ta déclaration de variable objet :ccool:
L'alimentation de la variable tableau est rigoureuse et précise.

N'oublie pas de placer cette discussion en mode "résolu"

Bonne continuation et à bientôt pour de nouvelles discussions

Bonjour,

Merci pour ta réponse.

Je vais analyser ta solution :)

Pour l'instant j'ai presque tout résolu.
J'ai eut quelques surprise ce matin, en relançant ma macro qui fonctionnait bien hier, j'ai constaté des bugs étranges :
- Au lieu de copier mes graphiques j'avais des données du presse papier…
Apres avoir fermé et relancer le fichier Excel :
- Uniquement le 1er graphique était copié dans le mail et 10 fois. (J'ai 10 graphiques en tout)
Je me suis rendu compte qu'il fallait que j'ai visualisé ces graphiques, avec un simple scroll de souris sur l'ensemble des graphs de mon onglet...
J'utilise une solution de contournement qui n'est sans doute pas des plus "élégante" mais qui fonctionne.

Il me reste encore le problème de la signature automatique que je n'arrive pas à ajouter par macro malgré mes divers tests avec du code trouvé sur le net.
Pas trop grave, si je n'ai plus que cette manip à réaliser manuellement.

Voici mon code actuel :

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 
Sub CopyAllChartsToOutlookEmail()
    Dim objOutlookApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim objMailDocument As Word.Document
    Dim objSheet As Excel.Worksheet
    Dim objChart As Excel.ChartObject
    Dim objChartTableau(10) As Excel.ChartObject
    Dim i, j As Integer
    Dim Desti, CC, Sujet, Semaine, NumSemTxt As String
    Dim NumSem As Byte, Année As Integer
 
    'Suite à un bug sur l'affichage des graphes j'ai rajouté ces lignes de selection des celllues où se trouve mes graphiques
    'En effet sans cette astuce, je n'ai que le PREMIER graph qui est copié 10 fois...
    ' ou je dois scroller avec la souris jusqu'à la fin de mes graphiques
    For i = 10 To 320 Step 30
        Range("A" & i).Select
    Next i
    Range("A12").Select
    'Get Outlook Application
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    If objOutlookApp Is Nothing Then
       Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    NumSem = NOSEM(Date - 7) 'ici je vais reprendre les données de ma semaine précédente (Graphiques basés sur S-1)
    Année = Year(Date - 7)
    If NumSem < 10 Then
        NumSemTxt = "0" & Trim(Str(NumSem))
    Else
        NumSemTxt = Trim(Str(NumSem))
    End If
 
    Sujet = "Données à jour de la semaine : S" & NumSemTxt & " - " & Année & " / Texte à ecrire"
    'Récup des destinataires du mail et des copies correspondants
    Desti = Sheets("RécapGraphPourSlides").Range("B1").Value
    CC = Sheets("RécapGraphPourSlides").Range("B2").Value
 
     'Create an Outlook Email
     Set objMail = objOutlookApp.CreateItem(olMailItem)
 
     With objMail
        .Display
        .Subject = Sujet
        .Recipients.Add Desti
        .CC = CC
        .Display
     End With
 
    Set objMailDocument = objMail.GetInspector.WordEditor
 
    i = 1
    For Each objSheet In ActiveWorkbook.Worksheets
        If objSheet.Name = "RécapGraphPourSlides" Then 'RécapGraphPourSlides=Nom de ma feuille
            For Each objChart In objSheet.ChartObjects
                Set objChartTableau(i) = objChart
                i = i + 1
            Next
        Exit For 'permet de sortir de la boucle du haut qui recherche tous les onglets du document. Pas des plus élégants...
        End If
    Next
    For i = 10 To 1 Step -1
        'Debug.Print i & " " & objChartTableau(i).Name
        objMailDocument.Range(0, 0) = Chr(10) & Chr(13)
        objChartTableau(i).Copy
        objMailDocument.Range(0, 0).Paste
        objMailDocument.InlineShapes(1).Width = 1400 * 0.75
        objMailDocument.InlineShapes(1).Height = 560 * 0.75
 
        If i = 10 Then objMailDocument.Range(0, 0) = vbCrLf & "Commentaires affichés avant le graphique 10*:" & vbCrLf
        If i = 6 Then objMailDocument.Range(0, 0) = vbCrLf & "Commentaires affichés avant le graphique 6 :" & vbCrLf
        If i = 5 Then objMailDocument.Range(0, 0) = vbCrLf & "Commentaires affichés avant le graphique 5" & vbCrLf
 
    Next i
    objMailDocument.Range(0, 0) = vbCrLf & "Bonjour," & vbCrLf & "Pour votre information, voici une synthèse des indicateurs à jour pour S" & NumSemTxt & vbCrLf & "Répartition des ....." & vbCrLf
 
End Sub

Cdt,
Cédric

Salut à toi,

En préambule,

Plutôt que
Code:

1 2 3 4 5 If NumSem < 10 Then NumSemTxt = "0" & Trim(Str(NumSem)) Else NumSemTxt = Trim(Str(NumSem)) End If
Tu peux utiliser la fonction Format qui retourne du texte.

D'autre part,
Code:

1 2 3 For Each objSheet In ActiveWorkbook.Worksheets If objSheet.Name = "RécapGraphPourSlides" Then 'RécapGraphPourSlides=Nom de ma feuille For Each objChart In objSheet.ChartObjects
peut se simplifier en

Code:

For Each objChart in Thisworkbook.Worksheets("RécapGraphPourSlides").ChartObjects

puis dans cette boucle
Code:

1 2 3 ObjChart.Copy 'suite = voir mon post précédent
1 autre détail

Je vois dans ton code
Code:

1 2 Desti = Sheets("RécapGraphPourSlides").Range("B1").Value CC = Sheets("RécapGraphPourSlides").Range("B2").Value
A priori, une cellule renverrait la liste des destinataires, 1 autre celle des mis en copie.

Je ne peux que te conseiller de gérer une plage pour chaque liste.

Voir à ce sujet, le processus que j'expose dans mon billet
Code:

1 2 3 4 5 Dim tb() As Variant ReDim tb(1 To rng_dest.Count) tb = Application.Transpose(rng_dest) liste_adresses = Join(tb, ";")
Ici, "rng_dest" désigne une variable Range correspondant à une plage d'une feuille utilitaire reportant les adresses mail des destinataires
Idem pour "rng_cc"

Et donc
Code:

1 2 3 With monitemoutlook .To = liste_adresses .Cc = listecopies
La gestion de ce processus sera d'autant plus facile.

06/03/2020, 23h57
Cedriclyon2020

Bonjour,

Merci pour toutes ces recommandations:)

Je testerai ça dans une dizaine de jour à mon retour de congés:)

Je clos le sujet.

Cdt,
Cédric