XL 2016 Export d'images + renommer celles-ci !

fougeron · 11 Août 2019

Bonjour à tous,

Je suis novice en Excel et j'essaie de trouver mon bonheur pour réussir à trouver une solution à mon problème. J'ai un fichier avec en colonne A des noms et en colonne B des images (photos) qui correspondent aux noms de la colonne A. J'essaie de faire un export des images qui seraient nommées par le nom qui correspond à chaque image en colonne A.

J'ai trouvé des macros sur ce forum qui arrivent à me faire un export et à renommer mais chaque images est vierge (blanche) ! Donc, ça ne fonctionne pas. En cherchant sur internet j'ai trouvé cette macro !

Sub ExtractionImagesFeuille()
Dim Pict As Picture
Dim Nb As Byte
Dim ChartObj As ChartObject

For Each Pict In ActiveSheet.Pictures
Pict.CopyPicture 'copie l'image
Set ChartObj = ActiveSheet.ChartObjects.Add(0, 0, Pict.Width, Pict.Height)
ChartObj.Activate
ChartObj.Chart.Paste 'colle l'image dans un graphique temporaire
ChartObj.Chart.Export "C:\Users\m.fougeron\downloads\" & Pict.Name & ".jpg", "jpg" 'Sauvegarde au format image, dans le même répertoire que ce classeur.
Nb = ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(Nb).Delete 'Supprime le graphique
Next Pict

End Sub

Elle fonctionne parfaitement ! Elle me fait un export des photos. Par contre j'ai de modifier ça pour que cette Macro me renomme les photos avec les noms de la colonne A mais je n'y arrive pas... Je commence à désespérer !

De plus, cette macro exporte les photos par rapport à leurs tailles dans le fichier excel ! est-il possible d'avoir un export à la taille réelle de l'image avant l'intégration dans excel ?

Je vous joins un exemple en pièce jointe ! La macro est déjà intégrée dedans.

Si à tout hasard l'un de vous peut m'expliquer comment faire, ce serait top.

Merci à vous d'avoir pris le temps de me lire.

Staple1600 · 11 Août 2019

Bonjour le fil, fougeron

fougeron
Essaies avec cette modification

VB:

Sub ExtractionImagesFeuille()
    Dim Pict As Picture
    Dim Nb As Byte
    Dim ChartObj As ChartObject
    For Each Pict In ActiveSheet.Pictures
        Pict.CopyPicture 'copie l'image
            Set ChartObj = ActiveSheet.ChartObjects.Add(0, 0, Pict.Width, Pict.Height)
            ChartObj.Activate
            ChartObj.Chart.Paste 'colle l'image dans un graphique temporaire
            ChartObj.Chart.Export "C:\Users\m.fougeron\downloads\" & Pict.TopLeftCell.Offset(, -1) & ".jpg", "jpg" 'Sauvegarde au format image, dans le même répertoire que ce classeur.
        Nb = ActiveSheet.ChartObjects.Count
        ActiveSheet.ChartObjects(Nb).Delete 'Supprime le graphique
    Next Pict
End Sub

NB: Reste à traiter le cas des éventuels caractères interdits dans le nom des images et/ou les cellules vides.

fougeron · 11 Août 2019

Staple1600 à dit:

Bonjour le fil, fougeron

fougeron
Essaies avec cette modification

VB:

Sub ExtractionImagesFeuille()
    Dim Pict As Picture
    Dim Nb As Byte
    Dim ChartObj As ChartObject
    For Each Pict In ActiveSheet.Pictures
        Pict.CopyPicture 'copie l'image
            Set ChartObj = ActiveSheet.ChartObjects.Add(0, 0, Pict.Width, Pict.Height)
            ChartObj.Activate
            ChartObj.Chart.Paste 'colle l'image dans un graphique temporaire
            ChartObj.Chart.Export "C:\Users\m.fougeron\downloads\" & Pict.TopLeftCell.Offset(, -1) & ".jpg", "jpg" 'Sauvegarde au format image, dans le même répertoire que ce classeur.
        Nb = ActiveSheet.ChartObjects.Count
        ActiveSheet.ChartObjects(Nb).Delete 'Supprime le graphique
    Next Pict
End Sub

NB: Reste à traiter le cas des éventuels caractères interdits dans le nom des images et/ou les cellules vides.

Roh... Incredible ! C'est parfait ! incroyable ! merci beaucoup beaucoup ! ça va bien m'aider ça ! puis-je me permettre une dernière question ? si je veux que mes images soient plus grandes à l'export, dois-je impérativement les agrandir dans le document excel où bien la macro est capable de le faire pour moi en retouchant quelque chose ? D'avance merci.

Staple1600 · 11 Août 2019

Re

Non, ce n'est pas parfait
Par exemple, en A1 saisis ceci
Abbey<>Road?
et efface le contenu de B1
puis relances la macro, et tu verras ce que je voulais dire

Pour le reste, je t'encourage (si tu ne l'as pas encore fait) à consulter les archives du forum.
Tu y trouveras sans doute de quoi t'aider.

fougeron · 11 Août 2019

Staple1600 à dit:
Re

Non, ce n'est pas parfait
Par exemple, en A1 saisis ceci
Abbey<>Road?
et efface le contenu de B1
puis relances la macro, et tu verras ce que je voulais dire

Pour le reste, je t'encourage (si tu ne l'as pas encore fait) à consulter les archives du forum.
Tu y trouveras sans doute de quoi t'aider.

Ah oui effectivement !!! il n'exporte pas les caractères spéciaux ! sincèrement, je vais m'en contenter ! merci beaucoup ! je vais chercher dans le forum pour cette histoire de taille d'image. Merci encore à toi.

fougeron · 11 Août 2019

Staple1600 à dit:

Bonjour le fil, fougeron

fougeron
Essaies avec cette modification

VB:

Sub ExtractionImagesFeuille()
    Dim Pict As Picture
    Dim Nb As Byte
    Dim ChartObj As ChartObject
    For Each Pict In ActiveSheet.Pictures
        Pict.CopyPicture 'copie l'image
            Set ChartObj = ActiveSheet.ChartObjects.Add(0, 0, Pict.Width, Pict.Height)
            ChartObj.Activate
            ChartObj.Chart.Paste 'colle l'image dans un graphique temporaire
            ChartObj.Chart.Export "C:\Users\m.fougeron\downloads\" & Pict.TopLeftCell.Offset(, -1) & ".jpg", "jpg" 'Sauvegarde au format image, dans le même répertoire que ce classeur.
        Nb = ActiveSheet.ChartObjects.Count
        ActiveSheet.ChartObjects(Nb).Delete 'Supprime le graphique
    Next Pict
End Sub

NB: Reste à traiter le cas des éventuels caractères interdits dans le nom des images et/ou les cellules vides.

Oh bah mince... Avec mon fichier def, j'ai une erreur 1004 il m'exporte 87 fichiers sur les 1938 existants ! Pourtant, je n'ai aucun caractère spécial (ce sont des noms et prénoms).

Staple1600 · 11 Août 2019

Re

Les noms sont bien en colonne A?
Quelle est l'adresse de la dernière cellule non vide de la colonne A?

fougeron · 11 Août 2019

Staple1600 à dit:
Re

Les noms sont bien en colonne A?
Quelle est l'adresse de la dernière cellule non vide de la colonne A?

Oui oui, tous les noms sont en colonne A ! la dernière ligne de nom en A est A1938 (c'est ça que l'on appelle une adresse ?)

Staple1600 · 11 Août 2019

Re

Essaies sur une copie de ton classeur où tu ne laisses que des noms et prénoms que jusqu'en A88
(et donc supprimes également les images suivantes)
Il ne doit rester que les images correspondantes aux cellules A1:A88
Puis relances la macro (ta copie du classeur sera enregistrée dans un dossier vide)
Est-ce que le message d'erreur se produit?

fougeron · 11 Août 2019

Staple1600 à dit:
Re

Essaies sur une copie de ton classeur où tu ne laisses que des noms et prénoms que jusqu'en A88
(et donc supprimes également les images suivantes)
Il ne doit rester que les images correspondantes aux cellules A1:A88
Puis relances la macro (ta copie du classeur sera enregistrée dans un dossier vide)
Est-ce que le message d'erreur se produit?

Alors je n'ai pas de message d'erreur mais j'ai un export de 39 photos sur les 88 existantes ! c'est très très bizarre !

fougeron · 11 Août 2019

fougeron à dit:
Alors je n'ai pas de message d'erreur mais j'ai un export de 39 photos sur les 88 existantes ! c'est très très bizarre !

Je me demande si certaines photos ne sont pas en format "PNG" car je viens de faire un test en retirant les noms et en marquant à la place Test 1, Test 2, Test 3, etc... Et après l'export ! je n'ai pas les photos de Test 1 à Test 22, puis de Test 24 à Test 34... et ensuite quelques photos manquantes !!! très bizarre.

Mais j'ai toujours 39 photos sur les 88 du tableau Test.

Staple1600 · 11 Août 2019

Re

Alors continuons les investigations
Lances ces deux macros

VB:

Sub testImages1()
 Dim Pict As Picture, NomIMG As String
    For Each Pict In ActiveSheet.Pictures
    NomIMG = Pict.TopLeftCell.Offset(, -1)
    Range(Pict.BottomRightCell.Offset(, 1).Address) = NomIMG
    Next Pict
End Sub
Sub testImages2()
MsgBox ActiveSheet.Pictures.Count
End Sub

A TESTER sur une copie
1) Avec la macro 1, tu dois avoir une valeur pour chaque image qui sera inscrite en colonne C.
Est-ce bien le cas? Il n'y aucune cellule vide après l’exécution de la macro?

2) La macro 2 te donne le nombre d'images présentes sur ta feuille.
Qu'affiche la MsgBox ?

fougeron · 11 Août 2019

Staple1600 à dit:
Re

Alors continuons les investigations
Lances ces deux macros

VB:

Sub testImages1() Dim Pict As Picture, NomIMG As String For Each Pict In ActiveSheet.Pictures NomIMG = Pict.TopLeftCell.Offset(, -1) Range(Pict.BottomRightCell.Offset(, 1).Address) = NomIMG Next Pict End Sub Sub testImages2() MsgBox ActiveSheet.Pictures.Count End Sub

A TESTER sur une copie
1) Avec la macro 1, tu dois avoir une valeur pour chaque image qui sera inscrite en colonne C.
Est-ce bien le cas? Il n'y aucune cellule vide après l’exécution de la macro?

2) La macro 2 te donne le nombre d'images présentes sur ta feuille.
Qu'affiche la MsgBox ?

Après test de la première macro, je n'ai aucune valeur en colonne C. La seconde Macro elle me dit que j'ai 91 Images.

fougeron · 11 Août 2019

fougeron à dit:
Après test de la première macro, je n'ai aucune valeur en colonne C. La seconde Macro elle me dit que j'ai 91 Images.

Donc si ça se trouve, j'ai des images superposées ce qui pose problème pour nommer les photos lors de l'export... Et si en plus dans tout ça il y a des ;png... alors là... Où va le monde ! On peut définitivement dire que je ne suis pas soigneux.

Staple1600 · 11 Août 2019

Re

Je suis parti du principe, que ton classeur original est structuré comme ton fichier exemple
(Les noms/prénoms en colonne A et les images en colonne B)
Testes sur le fichier que tu as posté ici
Tu verras que la macro 1 remplis bien la colonne C et que la seconde affiche 3.

XL 2016 Export d'images + renommer celles-ci !

fougeron

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

fougeron

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

fougeron

XLDnaute Nouveau

fougeron

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

fougeron

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

fougeron

XLDnaute Nouveau

fougeron

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

fougeron

XLDnaute Nouveau

fougeron

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Discussions similaires