Objets. graph. en png

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

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

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

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

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

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

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

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