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