Extraire des photos d'un onglet

Le 15/03/2018 à 08:56

Bonjour le forum,

J'ai un onglet données ainsi qu'un nommées TDC_Stat.

J'aimerai via une macro sauvegarder en format .PNG certains objets de la feuille TDC_Stat exemples :

Graphique 1
Graphique 2
Graphique 3
Rectangle 3...

l'idée serait de créer plusieurs photos format PNG dans la racine du fichiers source (ou si possible définir un répertoire)

Merci de votre aide

Le 15/03/2018 à 14:36

Bonjour,

avez vous vu sur le site dans la partie "téléchargement" ceci :

https://www.excel-pratique.com/fr/telechargements/utilitaires/koala-outil-export-image-excel-no320.php

@ bientôt

LouReeD

Le 15/03/2018 à 14:57

Bonjour,

Voici un exemple,

'enregistrer le graph en image
Set MyChart = Sheets("TDC_Stat").ChartObjects(1).Chart
MyChart.Export Filename:=ThisWorkbook.Path & "\graph1.png", filtername:="png"

Le 15/03/2018 à 15:27

Bonjour,

J'aimerai que lorsque je lance une sauvegarde il copie tous les graphiques et objets et les transformes en photo format PNG.

dans l'exemple koala il copie que les images pas les

Graphique

ni les

formes

Merci

Le 15/03/2018 à 20:54

Bonjour,

Voici un exemple pour les shapes de la feuille "TDC_Stat"

sur l'onglet "temp" il y un graphique qui sert de réceptacle pour les images. (ne supprimer pas cette onglet)

16graph-en-image.xlsm (20.76 Ko)

Sub Export_Shape()
'enregistrer shape et graph en image
Application.ScreenUpdating = False
For i = 1 To Sheets("TDC_Stat").Shapes.Count
 If Sheets("TDC_Stat").Shapes(i).Type <> msoChart Then
    Sheets("TDC_Stat").Shapes(i).CopyPicture
    Sheets("temp").Select
'    ce graph est utiliser comme réceptacle de l'image
    ActiveSheet.ChartObjects("Graphique 1").Activate
    ActiveChart.Paste
    With Sheets("temp").ChartObjects(i).Chart
      .Export Filename:=ThisWorkbook.Path & "\___shape" & i & ".png", filtername:="png"
    End With
    ActiveChart.Pictures(1).Delete
 Else
    Set MyChart = Sheets("TDC_Stat").Shapes(i).Chart
    MyChart.Export Filename:=ThisWorkbook.Path & "\___graph" & i & ".png", filtername:="png"
 End If
Next
Sheets("TDC_Stat").Select
Application.ScreenUpdating = True
End Sub

Le 16/03/2018 à 09:20

Merci sabV,

Par contre j'ai des erreurs quand j'ai des objets?

Egalement n'est-il pas possible de supprimer la

onglet test

?

Puis j'aimerai que la macro s'exécute automatiquement lors de la sauvegarde du fichier.

Dernière question j'ai une cadre sur l'image est-il possible de pas créer de cadre?

A+

Le 16/03/2018 à 15:20

Bonjour,

pouvez-vous joindre votre fichier ?

Le 20/03/2018 à 12:30

Voici le fichier

J'aimerai copier les objets de l'onglet

20donnees-fiches-idees-graph.xlsm (87.70 Ko)

Le 20/03/2018 à 14:44

Bonjour,

12clyver-donnees-fiches-idees-graph.xlsm (86.72 Ko)

à tester,

Sub Export_Shape()
'enregistrer shape et graph en image
Application.ScreenUpdating = False
Répertoire = "C:\Users\dario\Desktop\encours\"

Set sh1 = Sheets("TDC_Stat")
Set sh2 = Worksheets.Add
sh2.Shapes.AddChart

For i = 1 To sh1.Shapes.Count
 Select Case sh1.Shapes(i).Type
  Case 3  'msoChart
    Set MyChart = sh1.Shapes(i).Chart
    MyChart.Export Filename:=Répertoire & "\___graph" & i & ".png", filtername:="png"

  Case Else
    sh1.Shapes(i).CopyPicture
    sh2.Select
'    ce graph est utiliser comme réceptacle des images
    sh2.ChartObjects("Graphique 1").Activate
    ActiveChart.Paste
    With sh2.ChartObjects("Graphique 1").Chart
      .Export Filename:=Répertoire & "\" & sh1.Shapes(i).Name & ".png", filtername:="png"
    End With
    ActiveChart.Pictures(1).Delete
 End Select
Next

sh1.Select
Application.DisplayAlerts = False
sh2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Le 20/03/2018 à 17:13

Salut, rien ne se passe? j'ai oublié un truc?

Le 20/03/2018 à 19:15

Bonjour,

Salut, rien ne se passe? j'ai oublié un truc?

5clyver-donnees-fiches-idees-graph.xlsm (84.29 Ko)

il faut ajouter la macro à l'événement de votre choix,

par exemple pour exécuter la macro "Export_Shape" à l'ouverture du fichier,

copier la macro suivante sur la page code de ThisWorkbook (ps/ c'est déjà fait dans le fichier joint)

Private Sub Workbook_Open()
Export_Shape
End Sub

j'ai fais une petite modification pour le nom des images provenant de graphique

Sub Export_Shapes()
'enregistrer shape et graph en image
Application.ScreenUpdating = False
Répertoire = "C:\Users\dario\Desktop\encours\"  'à adapter

Set sh1 = Sheets("TDC_Stat")
'ce graph sera utiliser comme réceptacle des images
Set sh2 = Worksheets.Add
sh2.Shapes.AddChart

For i = 1 To sh1.Shapes.Count
 Select Case sh1.Shapes(i).Type
  Case 3  'msoChart
    Set MyChart = sh1.Shapes(i).Chart
    MyChart.Export Filename:=Répertoire & sh1.Shapes(i).Name & ".png", filtername:="png"

  Case Else
    sh1.Shapes(i).CopyPicture
    sh2.Select
    sh2.ChartObjects("Graphique 1").Activate
    ActiveChart.Paste
    With sh2.ChartObjects("Graphique 1").Chart
      .Export Filename:=Répertoire & sh1.Shapes(i).Name & ".png", filtername:="png"
    End With
    ActiveChart.Pictures(1).Delete
 End Select
Next

sh1.Select
Application.DisplayAlerts = False
sh2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Le 21/03/2018 à 08:49

Bonjour tjrs aucune image dans mon répertoire cible?

j'ai modifié :

Private Sub Workbook_Open()
Export_Shapes
End Sub

Merci

PS : dans le code ci dessous :

https://forum.excel-pratique.com/download/file.php?mode=view&id=188763

J'avais les graph converti en (.png) mais pas les images ni les objets

Le 22/03/2018 à 15:36

Personne ne peut m'aider sur ce problème?

Le 23/03/2018 à 16:12

Bonjour,

désolé, je vous avoue ne pas avoir tout suivi...

@ bientôt

LouReeD

Le 23/03/2018 à 16:47

Bonjour à tous,

clyver, pourriez-vous nous dire ce qui ne va pas avec le code proposé le 20 mars 2018, 19:15 (à part le « s » manquant) ?

Le 23/03/2018 à 18:34

via le code :

Sub Export_Shapes()
'enregistrer shape et graph en image
Application.ScreenUpdating = False
Répertoire = "C:\Users\dario\Desktop\encours\"  'à adapter

Set sh1 = Sheets("TDC_Stat")
'ce graph sera utiliser comme réceptacle des images
Set sh2 = Worksheets.Add
sh2.Shapes.AddChart

For i = 1 To sh1.Shapes.Count
 Select Case sh1.Shapes(i).Type
  Case 3  'msoChart
    Set MyChart = sh1.Shapes(i).Chart
    MyChart.Export Filename:=Répertoire & sh1.Shapes(i).Name & ".png", filtername:="png"

  Case Else
    sh1.Shapes(i).CopyPicture
    sh2.Select
    sh2.ChartObjects("Graphique 1").Activate
    ActiveChart.Paste
    With sh2.ChartObjects("Graphique 1").Chart
      .Export Filename:=Répertoire & sh1.Shapes(i).Name & ".png", filtername:="png"
    End With
    ActiveChart.Pictures(1).Delete
 End Select
Next

sh1.Select
Application.DisplayAlerts = False
sh2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Salut, j'ai les images qui perde en résolution ainsi que la taille d'enregistrement et déformé?

Merci

Le 23/03/2018 à 20:28

Bonjour,

j'ai les images qui perde en résolution ainsi que la taille d'enregistrement et déformé?

j'ai ajusté la largeur et la hauteur du graph "réceptacle" pour éviter que les images soient déformées,

est ce que c'est mieux comme ça ?

Sub Export_Shapes()
'enregistrer shape et graph en image
Application.ScreenUpdating = False
Répertoire = "C:\Users\dario\Desktop\encours\"

Set sh1 = Sheets("TDC_Stat")

'ce graph sera utiliser comme réceptacle des images
Set sh2 = Worksheets.Add
Set cObj = sh2.Shapes.AddChart

For i = 1 To sh1.Shapes.Count
 'ajuste le graph "réceptacle" à la forme du Shape(i)
  With cObj
    .Width = sh1.Shapes(i).Width
    .Height = sh1.Shapes(i).Height
  End With

 Select Case sh1.Shapes(i).Type

  Case 3  'msoChart
    Set MyChart = sh1.Shapes(i).Chart
    MyChart.Export Filename:=Répertoire & sh1.Shapes(i).Name & ".png", filtername:="png"

  Case Else
    sh1.Shapes(i).CopyPicture
    sh2.Select
    cObj.Select

    With ActiveChart
    .Paste
    .Export Filename:=Répertoire & sh1.Shapes(i).Name & ".png", filtername:="png"
    .Pictures(1).Delete
    End With
 End Select
Next

sh1.Select
Application.DisplayAlerts = False
sh2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Le 24/03/2018 à 07:17

Merci pour la modification de l'effet écrasé des images par contre peut-on augmenter la qualité final de la résolution des images générer en . PNG?

Car j'aimerai les utiliser sur une présentation TV HD.

PS à ce jour les graphiques pixélise vu la résolution du format 167*170

Merci et bonne fin de semaine

Le 24/03/2018 à 08:54