Pouvoir enregistrer une image à un nom spécifique

Le 18/03/2021 à 18:28

Bonjour,

J'essaye d'automatiser le fait d'enregistrer une image qui se trouve dans une cellule avec un nom qui se trouve dans une autre cellule sur la même ligne, sauf que je ne parviens pas à le faire, je me retrouve à le faire manuellement et c'est pénible.

Auriez-vous une idée de comment je pourrai:

- automatiser l'enregistrement en indiquant à excel quelle colonne prendre pour l'image et quelle colonne prendre pour le nom

- garder les dimensions réelles de l'image (que ça ne la rende pas plus petite)

J'ai mis ci-joint un fichier exemple.

Merci d'avance!

34exemple.xlsx (12.70 Ko)
Le 18/03/2021 à 21:54

J'ai trouvé une formule Excel mais qui ne fonctionne pas chez moi (l'auteur de cette formule l'a appelée "save picture from Excel") même en changeant le savepath, je ne comprends pas pourquoi. Cela enregistre une image qui n'est pas dans mon fichier, probablement car "Picture 1" n'existe pas. Il faudrait que j'arrive à modifier cela pour qu'il prenne la cellule de l'image et ensuite Il ne manquerait plus qu'à rajouter l'information du nom avec la cellule dédiée. C'est possible ou j'ai tout faux?

Sub SavePictureFromExcel()

Dim myPic As Shape
Dim tempChartObj As ChartObject
Dim savePath As String

Set myPic = ActiveSheet.Shapes("Picture 1")
Set tempChartObj = ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height)
savePath = "C:\Users\marks\Downloads\mySavedPic.jpg"

'Copy picture into chart, then export chart
myPic.Copy

tempChartObj.Chart.ChartArea.Select
tempChartObj.Chart.Paste
tempChartObj.Chart.Export savePath
tempChartObj.Delete

End Sub
Le 18/03/2021 à 22:29

Bonsoir,

une adaptation d'un code que j'ai intégrer dans mon jeu de QCM USF suite à une demande :

Sub LouReeD()
    Dim ligne, Sh As Object, ShWay
    ligne = 2
    With ActiveSheet
        Do
            If .Cells(ligne, 1).Value = "" Then Exit Do
            For Each Sh In .Shapes
                If Not Intersect(.Cells(ligne, 2), Sh.TopLeftCell) Is Nothing Then
                    Sh.Copy
                    With Sh.Parent.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
                        While .Shapes.Count = 0
                            DoEvents
                            .Paste
                        Wend
                        ShWay = ActiveWorkbook.Path & "\" & ActiveSheet.Cells(ligne, 1).Value & ".jpg"
                        .Export ShWay, "PNG"
                        .Parent.Delete
                    End With
                    Exit For
                End If
            Next
            ligne = ligne + 1
        Loop
    End With
End Sub

Ici les images sont crées dans le dossier du classeur.

@ bientôt

LouReeD

Le 18/03/2021 à 22:54

Merci beaucoup cela fonctionne!

Par contre si l'image est dans une petite cellule cela l'enregistre en tout petit, est-il possible de modifier cela ou bien comme c'est la taille de l'image dans excel il faut faire avec?

Le 18/03/2021 à 23:03

Il faut alors (peut-être) faire des tests avant ceci :
With Sh.Parent.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
afin de modifier des valeurs trop petites et voir ce que cela donne, par exemple :
If Sh.Width < 10 then Sh.Width = 150

@ bientôt

LouReeD

Le 18/03/2021 à 23:09

Le code :

Sub LouReeD()
    Dim Ligne, Sh As Object, ShWay, Largeur
    Application.ScreenUpdating = False
    Ligne = 2
    With ActiveSheet
        Do
            If .Cells(Ligne, 1).Value = "" Then Exit Do
            For Each Sh In .Shapes
                If Not Intersect(.Cells(Ligne, 2), Sh.TopLeftCell) Is Nothing Then
                    If Sh.Width < 500 Then
                        Largeur = Sh.Width
                        Sh.Width = 600
                    End If
                    Sh.Copy
                    With Sh.Parent.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
                        While .Shapes.Count = 0
                            DoEvents
                            .Paste
                        Wend
                        ShWay = ActiveWorkbook.Path & "\" & ActiveSheet.Cells(Ligne, 1).Value & ".Png"
                        .Export ShWay, "PNG"
                        .Parent.Delete
                    End With
                    Sh.Width = Largeur
                    Exit For
                End If
            Next
            Ligne = Ligne + 1
        Loop
    End With
End Sub

@ bientôt

LouReeD

Le 18/03/2021 à 23:55

Merci! Est-il facile de transformer ta formule dans un bouton qui me donne la possibilité d'indiquer la colonne pour l'image et pour le nom?

Le 19/03/2021 à 22:23

Bonsoir,

ce n'est pas compliqué, on ajoute deux variables et deux InputBox et voilà le code :

Sub LouReeD()
    Dim Ligne, Sh As Object, ShWay, Largeur, Réponse, ColonneI, ColonneN

    Réponse = InputBox("Veuillez indiquer la colonne du nom des images", "Désignation de la colonne pour le nom")
    ColonneN = Asc(UCase(Réponse)) - 64
    Réponse = InputBox("Veuillez indiquer la colonne des images", "Désignation de la colonne pour l'image")
    ColonneI = Asc(UCase(Réponse)) - 64

    ' un petit test de cohérence mais il en faudrait d'autre...
    If ColonneI = ColonneN Then MsgBox ("Ces colonnes ne peuvent être identiques..."): End

    Application.ScreenUpdating = False
    Ligne = 2
    With ActiveSheet
        Do
            If .Cells(Ligne, ColonneN).Value = "" Then Exit Do
            For Each Sh In .Shapes
                If Not Intersect(.Cells(Ligne, ColonneI), Sh.TopLeftCell) Is Nothing Then
                    If Sh.Width < 500 Then
                        Largeur = Sh.Width
                        Sh.Width = 600
                    End If
                    Sh.Copy
                    With Sh.Parent.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
                        While .Shapes.Count = 0
                            DoEvents
                            .Paste
                        Wend
                        ShWay = ActiveWorkbook.Path & "\" & ActiveSheet.Cells(Ligne, ColonneN).Value & ".Png"
                        .Export ShWay, "PNG"
                        .Parent.Delete
                    End With
                    Sh.Width = Largeur
                    Exit For
                End If
            Next
            Ligne = Ligne + 1
        Loop
    End With
End Sub

@ bientôt

LouReeD

Le 19/03/2021 à 23:27

Merci beaucoup !! Cependant, une erreur survient lorsque le script se lance après qu'une ou deux images aient été enregistrées:

image image

Cela enregistre pourtant bien les premières images dans le dossier où se trouve le fichier Excel, qu'est-ce qui provoque l'erreur?

Edit: je constate des modifications dans le fichier (des noms d'images qui viennent s'inscrire sous certaines images, des images qui deviennent grandes dans le fichier), serait-ce dû au fait qu'un filtre est appliqué?

Le 20/03/2021 à 02:18

Pour le filtre peut-être ! Il faut tout donner comme info dès le départ !

Ensuite, dès qu'il y a une erreur, un shape "blanc" peu rester sur la feuille et du coup si on relance le code cela provoque l'erreur indiquée. Il faut que le fichier soit "propre" avant le fonctionnement.

Je regarde ce que je peux faire.

@ bientôt

LouReeD

Le 20/03/2021 à 02:25

Un nouvel essai pour prendre en compte que les lignes peuvent être masquées :

Sub LouReeD()
    Dim Ligne, Sh As Object, ShWay, Largeur, Réponse, ColonneI, ColonneN

    Réponse = InputBox("Veuillez indiquer la colonne du nom de ces images", "Désignation de la colonne pour le nom")
    ColonneN = Asc(UCase(Réponse)) - 64
    Réponse = InputBox("Veuillez indiquer la colonne des images", "Désignation de la colonne pour l'image")
    ColonneI = Asc(UCase(Réponse)) - 64

    ' un petit test de cohérence mais il en faudrait d'autre...
    If ColonneI = ColonneN Then MsgBox ("Ces colonnes ne peuvent être identiques..."): End

    Application.ScreenUpdating = False
    Ligne = 2
    With ActiveSheet
        Do
            If .Cells(Ligne, ColonneN).Value = "" Then Exit Do
            If .Cells(Ligne, ColonneN).EntireRow.Hidden = False Then
                For Each Sh In .Shapes
                    If Not Intersect(.Cells(Ligne, ColonneI), Sh.TopLeftCell) Is Nothing Then
                        If Sh.Width < 500 Then
                            Largeur = Sh.Width
                            Sh.Width = 600
                        End If
                        Sh.Copy
                        With Sh.Parent.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
                            While .Shapes.Count = 0
                                DoEvents
                                .Paste
                            Wend
                            ShWay = ActiveWorkbook.Path & "\" & ActiveSheet.Cells(Ligne, ColonneN).Value & ".Png"
                            .Export ShWay, "PNG"
                            .Parent.Delete
                        End With
                        Sh.Width = Largeur
                        Exit For
                    End If
                Next
            End If
            Ligne = Ligne + 1
        Loop
    End With
End Sub

J'ai juste ajouté une condition "EntireRow.Hidden = Flase", comme quoi la ligne doit être visible pour que le code soit exécuté.

@ bientôt

LouReeD

Le 20/03/2021 à 12:59

Désolé je ne pensais pas que l'information du filtre était importante haha.. Désormais tout fonctionne correctement, merci beaucoup!

Le 20/03/2021 à 13:04

Merci pour vos remerciements !

@ bientôt

LouReeD

Rechercher des sujets similaires à "pouvoir enregistrer image nom specifique"