[XL-2016] Excel vba email redimensionner image

Bonjour,

J'ai le code ci-dessous qui me permet de mettre en forme un email sous Outlook à partir d'Excel.
Il contient des plages de cellules et un graphique sous forme d'image.

Il fonctionne, cependant, je souhaite redimensionner l'image du graphique dans le corps du mail pour en réduire la taille.
Je n'ai pas trouvé l'astuce sur le forum, pouvez-vous, svp, m'aider ?

Merci d'avance.
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
 
Sub Mail_avec_image()
 
Dim tableau_a_copier1 As Range
Dim tableau1 As String
Dim liste_destinataires As String
Dim liste_cc As String
Dim début As String
Dim outlookApp As Object
Dim NewMail As Object
Dim Fname1 As String
Dim Fname11 As String
 
With Application
        .ScreenUpdating = False
        .EnableEvents = False
End With
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'           Définir horodatage                            '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DateDuJour = Format(Date, "dd mmmm yyyy")
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'       Copier le tableau pour insérer dans email         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set tableau_a_copier1 = ActiveSheet.Range("a1:r4")
 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'       Copier les Graph                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Fname1 = Environ$("temp") & "\graph1.gif"
 ActiveWorkbook.Worksheets("indicateur").ChartObjects("Graphique 22").Chart.Export _
    FileName:=Fname1, FilterName:="GIF"
 
 
'''''''''''''''''''''''''''''''''''''
'        Liste de diffusion         '
'''''''''''''''''''''''''''''''''''''
nb_contacts = Worksheets("Tables").Cells(Rows.Count, "AB").End(xlUp).Row
nb_contacts_copie = Worksheets("Tables").Cells(Rows.Count, "AE").End(xlUp).Row
 
For i = 2 To nb_contacts
    liste_destinataires = liste_destinataires & Worksheets("Tables").Range("AB" & i) & ";"
Next i
 
For i = 2 To nb_contacts_copie
    liste_cc = liste_cc & Worksheets("Tables").Range("AE" & i) & ";"
Next i
 
 
''''''''''''''''''''''''''''''''
'        Corps du mail         '
''''''''''''''''''''''''''''''''
début = "<BODY style=font-size:10pt;font-family:Arial>Bonjour,<p><p>Vous trouverez ci-dessous les Indicateurs.<p>"
 
tableau1 = "<b><u><font size=+1><blockquote>" & "</blockquote></font></b></u>" & RangetoHTML(tableau_a_copier1)
 
Fname11 = "<IMG src=" & Fname1 & ">"
 
 
'''''''''''''''''''''''''''''''''''
'        Création du mail         '
'''''''''''''''''''''''''''''''''''
Set outlookApp = CreateObject("Outlook.Application")                                'ouverture d'Outlook
Set NewMail = outlookApp.CreateItem(0)                                              'ouverture d'un nouveau mail
On Error Resume Next
    With NewMail
        .Display                                                                    'déclare la signature du mail
        .To = liste_destinataires                                                   'écrit la liste de destinataires
        .CC = liste_cc                                                              'écrit la liste des personnes en copie
        .Subject = "Indicateurs | " & DateDuJour                                    'écrit l'objet du mail
        .HTMLBody = début & tableau1 & Fname11 & .HTMLBody                          'écrit le corps du mail
        .Display                                                                    'écrit la signature
    End With
On Error GoTo 0
 
'Supprimer le fichier temporaire
Kill Fname1
 
Set outlookApp = Nothing
Set NewMail = Nothing
 
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
 
End Sub
 
'---NE PAS TOUCHER--- Permet de copier/coller une plage de données en tableau sur un mail
 
Function RangetoHTML(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"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        'mise en forme colonnes
        Columns("A:I").Select
        Range("A1").Activate
        Cells.EntireColumn.AutoFit
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    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
 
    'Read all data from the htm file into RangetoHTML
    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=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function