Objets. graph. en png

Le
Dario Gmail
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 f=
euille TDC_Stat exemples :
- Graphique 1
- Graphique 2
- Graphique 3
- Rectangle 3

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

Puis j'aimerai que la macro s'exécute automatiquement lors de la sauve=
garde du fichier

Merci de votre aide
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Michd
Le #26467590
Bonjour,
Cette macro crée une image de tous les GRAPHES présents dans chaque feuille
du classeur. Évidemment, chaque graphe doit avoir un NOM DIFFÉRENT, car le
nom de l'image du graphe porte le nom du graphe dans le classeur et dans un
répertoire donné, 2 fichiers ne peuvent avoir le même nom.
Elle crée aussi le chemin où tu veux sauvegarder les images.
'-------------------------------------------------
Sub test()
Dim NomChart, NomFeuille As String
Dim Nomfichier As String, Nb As Long
Dim A As Long, Répertoire As String
Dim Feuille As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Répertoire = "F:Documents"
'La procédure suivante, crée le chemin indiqué
's'il n'exite pas, et s'il existe ne fais rien.
'le lecteur doit exister...
Call Créer_Répertoire(Répertoire)
For Each Feuille In ThisWorkbook.Worksheets
With Feuille
NomFeuille = .Name
With .ChartObjects
Nb = .Count
For A = 1 To Nb
NomChart = .Item(A).Name
Nomfichier = Répertoire & NomChart & ".png"
Call CréerImage(NomChart, NomFeuille, Nomfichier)
Next
End With
End With
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
'-------------------------------------------------
Sub CréerImage(NomChart, NomFeuille As String, _
Nomfichier As String)
Dim Sh As Worksheet
Application.ScreenUpdating = False
With Worksheets(NomFeuille)
.Shapes(NomChart).Copy
Set Sh = Worksheets.Add
With Sh
.Paste
With .ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
.Paste
.ChartArea.Border.LineStyle = 0
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export Nomfichier, "PNG"
End With
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End With
End With
End Sub
'-------------------------------------------------
Sub Créer_Répertoire(Répertoire As String)
Dim Commande As String
Commande = Environ("comspec") & " /c mkdir """ & Répertoire & """"
Shell Commande, 0
End Sub
'-------------------------------------------------
MichD
Dario Gmail
Le #26467634
Le vendredi 16 mars 2018 12:27:48 UTC+1, Michd a écrit :
Bonjour,
Cette macro crée une image de tous les GRAPHES présents dans ch aque feuille
du classeur. Évidemment, chaque graphe doit avoir un NOM DIFFÉR ENT, car le
nom de l'image du graphe porte le nom du graphe dans le classeur et dans un
répertoire donné, 2 fichiers ne peuvent avoir le même nom.
Elle crée aussi le chemin où tu veux sauvegarder les images.
'-------------------------------------------------
Sub test()
Dim NomChart, NomFeuille As String
Dim Nomfichier As String, Nb As Long
Dim A As Long, Répertoire As String
Dim Feuille As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Répertoire = "F:Documents"
'La procédure suivante, crée le chemin indiqué
's'il n'exite pas, et s'il existe ne fais rien.
'le lecteur doit exister...
Call Créer_Répertoire(Répertoire)
For Each Feuille In ThisWorkbook.Worksheets
With Feuille
NomFeuille = .Name
With .ChartObjects
Nb = .Count
For A = 1 To Nb
NomChart = .Item(A).Name
Nomfichier = Répertoire & NomChart & ".png"
Call CréerImage(NomChart, NomFeuille, Nomfichier)
Next
End With
End With
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
'-------------------------------------------------
Sub CréerImage(NomChart, NomFeuille As String, _
Nomfichier As String)
Dim Sh As Worksheet
Application.ScreenUpdating = False
With Worksheets(NomFeuille)
.Shapes(NomChart).Copy
Set Sh = Worksheets.Add
With Sh
.Paste
With .ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
.Paste
.ChartArea.Border.LineStyle = 0
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export Nomfichier, "PNG"
End With
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End With
End With
End Sub
'-------------------------------------------------
Sub Créer_Répertoire(Répertoire As String)
Dim Commande As String
Commande = Environ("comspec") & " /c mkdir """ & Répertoire & """"
Shell Commande, 0
End Sub
'-------------------------------------------------
MichD

Bonjour MichD,
Quelques précisions :
Est il possible de lui dire de faire une recherche que sur un onglet et non sur le classeur?
Il ne transforme pas les images ni les objets type insertion.
Puis j'aimerai que la macro s'exécute automatiquement lorsque j'enregi stre mon fichier.
Merci
Michd
Le #26467644
Si j'ai bien compris, tu veux faire une image de TOUS les objets d'une
feuille de calcul?
Comment s'appelle cette feuille, "données"?
Énumère les objets (nom) de cette feuille. Pour Excel, même les contrôles
"étiquettes" sont des objets. Je ne pense pas que tu veuilles avoir une
image de ces contrôles?
MichD
Dario Gmail
Le #26467648
Le vendredi 16 mars 2018 15:46:00 UTC+1, Michd a écrit :
Si j'ai bien compris, tu veux faire une image de TOUS les objets d'une
feuille de calcul?
Comment s'appelle cette feuille, "données"?
Énumère les objets (nom) de cette feuille. Pour Excel, mêm e les contrôles
"étiquettes" sont des objets. Je ne pense pas que tu veuilles avoir une
image de ces contrôles?
MichD

Re,
nom des graph. ==> MCA, ADD, PHM, P0
j'ai aussi des imports de photos nommé ==> Plan zone
Onglet ==> données
Merci
Michd
Le #26467665
Cette procédure transforme en image dans le répertoire de ton choix, tous
les images et graphiques de la feuille "Fiche idée". Certaines images sont
en double dans ta feuille et portent un nom différent.
Prends le temps de lire la procédure et de modifier certaines informations
le cas échéant.
'---------------------------------------------------
Sub test()
Dim NomChart, NomFeuille As String
Dim NomFichier As String, Nb As Long
Dim A As Long, Répertoire As String
Dim Feuille As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Répertoire = "F:DocumentsImage"
'La procédure suivante, crée le chemin indiqué
's'il n'exite pas, et s'il existe ne fais rien.
'le lecteur doit exister...
Call Créer_Répertoire(Répertoire)
With Worksheets("Fiche idée") 'nom feuille à détermine
NomFeuille = .Name
Call CréerImage(NomFeuille, Répertoire)
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
'-------------------------------------------------
Sub CréerImage(NomFeuille As String, Répertoire As String)
Dim Feuille As Worksheet, NomFichier As String
Dim Sh As Shape, Nom As String, T As Double
Set Feuille = Worksheets.Add
With Worksheets(NomFeuille)
For Each Sh In .Shapes
Nom = Sh.Name
Select Case Sh.Type
'3 représente graphe
'13 Image
'28 msoGraphic
'Tu inscris dans la ligne suivante
'seulement les numéros des objets
'que tu veux inclure comme image.
Case 3, 13, 28
NomFichier = Sh.Name
Sh.Copy
With Feuille
.Paste
With .ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
T = Timer + 1
Do While Timer <= T
DoEvents
.Paste
Loop
.Paste
Application.ScreenUpdating = True
.ChartArea.Border.LineStyle = 0
.Paste
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export Répertoire & Nom & ".png", "PNG"
End With
.DrawingObjects.Delete
End With
End Select
Next
End With
Application.DisplayAlerts = False
Feuille.Delete
Application.DisplayAlerts = True
End Sub
'-------------------------------------------------
Sub Créer_Répertoire(Répertoire As String)
Dim Commande As String
Commande = Environ("comspec") & " /c mkdir """ & Répertoire & """"
Shell Commande, 0
End Sub
'-------------------------------------------------
Michd
Dario Gmail
Le #26467684
bonsoir je regarde cela par contre la macro est manuel
Que dois-je faire pour la rendre automatique lors de l’enre Du fich ier?
Merci d’avance
Michd
Le #26467690
Les macros du message précédent doivent être placées dans un module standard
Modifie le nom de la macro appelée Sub Test () par
sub Générer_Les_Images_De_La_Feuille_Fiche_idée()
Dans le THISWORKBOOK du projetVBA du classeur, copie ce qui suit :
'----------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.EnableEvents = False
Call Générer_Les_Images_De_La_Feuille_Fiche_idée
ThisWorkbook.Save
Cancel = True
Application.EnableEvents = True
End Sub
'----------------------------------
MichD
Michd
Le #26467693
Dans le ThisWorkbook, voilà ce que tu dois copier.
'---------------------------------------
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Application.EnableEvents = True
Call Générer_Les_Images_De_La_Feuille_Fiche_idée
ThisWorkbook.Save
Cancel = True
Application.EnableEvents = True
End Sub
'---------------------------------------
MichD
Publicité
Poster une réponse
Anonyme