Discussion :

[Cedriclyon2020]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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.

[Cedriclyon2020]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Cedriclyon2020]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[MarcelG]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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
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

[Cedriclyon2020]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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