Enregistrement image - Macro - Astuce

Bonjour a tous

J'ai un fichier excel avec beaucoup de feuilles et pour chaque feuille je dois enregistrer les images. (environ 1500 photos par fichier et plus de 20 fichier à faire)

Ci dessous un exemple d'une feuille.

Pour chaque image je dois lui donner un nom qui commence par le numéro en cellule A5 + "_" + le numéro de la photo.

Sur l'exemple si dessus cela donnerai:

photo 1= 10_1 ; photo 2= 10_A ; photo 3 = 10_B ; photo 4 = 10_C ; photo 5 = 10_D

Faire cela à la main donne:

1- Agrandir mon image car sinon la taille est trop petite lorsque j'ouvre le jpeg

2- Clique droit + enregistrer en tant qu'image

3- Selectionner le dossier

4- Modifier le nom + le type (jpeg)

5- Enregistrer

Je sollicite donc ce super forum pour trouver quelques astuces qui me permetterons d'avancer plus vite!

(j'ai pensé a une macro qui ferai les étape 1 à 3, ce qui serait un gain de temps enorme car il me resterai plus qu'as mettre le numéro de la photo, ne sachant pas si cela est possible...)

Ci joint un fichier test

Bonjour

Ce n'est pas avec une photo que tu vas obtenir des réponses.

Un extrait de ton fichier serait beaucoup mieux

Cordialement

Bonjour Joco,

Un fichier à été joint à mon message précédent (voir tout en bas du message)

Je joint le meme fichier à ce message

Bonjour

bon j'ai commencé un truc mais j'avoue... je jette l'éponge...

il y a trop de choses qui ne vont pas...

il y a des photos qui sont regroupées avec des formes.. avec des sous groupes..... => groupe 27-> groupe 28 -> groupe 30 pour potentiellement prendre l'image 33 celle-là j'ai même pas essayé de la récupérer.

ensuite c'est pour récupérer le nom... il faudrait maintenant rechercher la position de l'elipse pour savoir si elle est sur l'image pour pouvoir construire les noms de sauvegarde : photo 2= 10_A ; photo 3 = 10_B ; photo 4 = 10_C ; photo 5 = 10_D

ci dessous un début de proposition... mais j'arrêté la.. cela fait l'export des photos avec un redimensionnement (a modifier si nécessaire) de la feuille active...

le nom de la photo est celui de l'image dans Excel. et se trouve dans le même dossier où se trouve le fichier exécutant le code..

Sub EXPORT()
Dim i As Integer

i = 1
For Each shp In ActiveSheet.Shapes
    If LCase(Left(shp.Name, 3)) = "pic" Or LCase(Left(shp.Name, 3)) = "ima" Then
        Select Case (Split(shp.Name, " ")(1))
            Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 16, 31, 45, 99
            Case Else
                If shp.Width > 50 Then Debug.Print shp.Name: enregistrement_shape shp.Name, i: i = i + 1
        End Select
    End If
Next
End Sub
Sub enregistrement_shape(nom As String, nb As Integer)
ActiveSheet.Shapes(nom).Copy
 Set oDia = ActiveSheet.ChartObjects.Add(0, 0, 1000, 1000)
    Set oChartArea = oDia.Chart
    oDia.Activate
    With oChartArea
        .ChartArea.Select
        .Paste
        Selection.ShapeRange.Height = 1000
        Selection.ShapeRange.Width = 1000
        .EXPORT Filename:=ThisWorkbook.Path & "\" & [A5] & "_" & nb & ".jpg", FilterName:="jpg"
    End With
    oDia.Delete
End Sub

voici un aperçu du résultat :

Fred

Bonjour Fred,

Merci pour ce bout de code (je le garde precieusement car cela peut etre utile pour d'autres cas)

En effet j'ai omis de preciser qu'il y a beaucoup de groupement d'images et de formes . Et lorsqu'il y a des formes et groupements d'images, c'est le groupe entier qu'il faut que j'enregistre.

La solution proposée est deja pas mal optimisée.

j'ai en tête une solution moin efficace, mais qui peut etre plus simple à coder. Pensez vous que cela est possible:

1- Selectionner l'objet (groupement d'image+forme ou image seule)

2- Executer la macro:

- Agrandir mon image car sinon la taille est trop petite lorsque j'ouvre le jpeg

- Clique droit + enregistrer en tant qu'image

- Prefix du nom de l'image (numéro en cellule A5) + "_"

3- Je fini le nom de l'image par donner le bon numéro (1-2-3...) OU incrémenter le numero de l'image à chaque relance de la macro

Je ne my connais pas vraiment en VBA donc je ne sais pas si ce que je porpose est possible, j'espere etre clair dans mes explications, !

Merci pour votre aide!

Re bonjour

cela me parait possible... Avant d'aller plus loin, est-ce que le redimensionnement proposer dans le code précédent convient ?

Fred

Yes, le redimensionnement proposé dans le code précédent est parfait !

Sinon j'imagine que ceux sont les lignes: Set oDia = ActiveSheet.ChartObjects.Add(0, 0, 1000, 1000) et Selection.ShapeRange.Height = 1000 Selection.ShapeRange.Width = 1000 qui définissent les dimensions de la photo.

Bonjour

j'ai un peu galéré avec tes groupements de formes... je n'arrive pas a faire fonctionner correctement la chose... c'est le redimensionnement qui pose problème... au pire ceux là faudra les faire à la main.. j'ai pas de solution...

sauf si quelqu'un d'autre trouve une solution.... mais j'ai pas trouvé..

j'ai mis le raccourci clavier ctrl+shift+i pour lancer la macro...

Dans le principe de fonctionnement, on sélectionne avec la souris l'image à sauvegarder -> raccourci clavier -> choisir le dossier de destination-> donner le nom du fichier sous lequel sera enregistré le fichier (sans son extension !! )

Fred

Hello,

Merci pour la macro, ca va me servir pour la moitié des photos!

J'ai vue que tu as fait une fonction pour le choix du dossier. Comme le dossier est toujour le meme pour toutes les photos d'un meme fichier, est-il possible de supprimer le fonction "choixdossier" et mettre l'emplacement voulu directement dans la macro (en l'occurence: \\fradkprodoq1\ProDoQ-DATA\DonneesProDoQ\Documents\Fonderie\ELT10\Standards\Mise en forme\Coulée Continue Verticale\Photos)

Pour ce qui est du redimenssionement, le graphique redimenssionne correctement les photos, je vais donc utiliser la macro pour les photos sans groupement.

Pour ce qui est des groupement de photos/formes, je vais continuer à la main.

La macro va m'aider à enregistrer la moitié des photos, c'est déja un gain de temps non négligeable!

Bonjour,

Excel n'est pas fait pour ça !

A+

Bonjour

Dans ce cas

remplacer la ligne

    dos = ChoixDossier

par

dos = "\\fradkprodoq1\ProDoQ-DATA\DonneesProDoQ\Documents\Fonderie\ELT10\Standards\Mise en forme\Coulée Continue Verticale\Photos"

et mettre en commentaire ou supprimer cette ligne qui n'a plus d'intérêt :

    If dos = "" Then Exit Sub

Fred

et....

Fred

Super ca fonctionne parfaitement!

Un grand merci pour le coup de main!

Hello, je fait un petit up du sujet.

J'ai trouvé comment faire pour que les groupement d'images s'affichent correctement.

'Copy/Paste Shape inside temporary chart
  ActiveShape.Copy
  ActiveSheet.Paste
  Set temp = Selection

  temp.ShapeRange.LockAspectRatio = msoTrue
  temp.ShapeRange.ScaleWidth 5, msoFalse

    temp.Copy
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, temp.Width, temp.Height)
    cht.Activate
    ActiveChart.Paste
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.ScaleWidth 5, msoFalse, msoScaleFromTopLeft
    'save chart to User's Desktop as PNG File
    cht.Chart.Export dos & "\" & myfile & ".jpg"

Apres avoir collé la séléction dans le graphique, il faut bloquer le ratio d'aspect et redimenssionner la selection:

Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.ScaleWidth 5, msoFalse, msoScaleFromTopLeft

Bonjour

tant mieux si une solution a été trouvée.

Bonne continuation

Fred