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

[fougeron]

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.

 

[patricktoulon]

rep sur #29
re oui absolument (gare au caractères spéciaux)

 

[patricktoulon]

pour info
une methode pour connaitre les dim d'une image

Sub testx()
    dimensions = dimention_image("H:\fond d'ecran\paysages\paysage3.jpg")
Debug.Print Join(dimensions, "X")
End Sub
Function dimention_image(chemin)
    Dim Img As Object
    With CreateObject("WIA.ImageFile"): .LoadFile chemin: dimention_image = Array(.Width, .Height): End With
End Function

 

[Staple1600]

Bonjour à tous,

Je suis novice en Excel et j'essaie de trouver mon bonheur

Il est peut-être un peu tôt pour WIA, non ? 😉
Attendons le retour de fougeron.

NB: Heureusement, que fougeron n'est pas MACiste 😉

 

[patricktoulon]

un peu tot 😱ui mais je pense au poids 1938 images🙄 excel n'aime pas ca (gare au gorille)

 

[Staple1600]

Re

On ne peut pas obliger nos petits camarades de jeu à se rappeler qu'à la base Excel est un tableur.
Et qu'il existe moult logiciels pour gérer/traiter les images.

Personnellement, je n'ai jamais eu l'occasion de faire défiler 1938 images et de lire leur noms dans des cellules Excel, dans le cadre d'un boulot. 😉
Ca doit prendre un sacré bout de temps. 😉

 

[patricktoulon]

a exporter avec un chart ho que oui peut être même plusieurs minutes ,avec api beaucoup moins mais je ne vais pas donner d'exemple sinon notre petit camarade va devoir investir dans l'aspirine 😉

 

[Staple1600]

Bonsoir lolostaps

[Pour infos]
L'usage c'est de créer sa propre discussion pour y poser sa question
C'est que tu as fait 😉
Et si les réponses tardent à venir, il faut faire ce qu'on appelle "un up"
(C'est à dire, se répondre à soi même dans sa discussion pour que celle-ci se ré-affiche en haut de la liste)
[/Pour infos]

NB: Poster sa question dans le fil d'un autre rend la lecture du fil moins fluide
(On sait plus qui a posé la question initiale et on ne sait plus à qui on réponds)

 

[laurent950]

Bonjour @patricktoulon et à tous,

Après plusieurs tests sur des PNG sur Feuille Excel (Plus de 500) sur une feuille a exporter, voici une solution fiable que j'ai validée et que je souhaite partager pour éviter les images blanches lors de l'exportation de graphiques ou d'images dans Excel. Cette astuce repose sur l'utilisation de certaines commandes spécifiques en VBA. Voici les points essentiels :

L'astuce clé :​

Entre ces deux lignes, activer le graphique temporaire est indispensable pour coller l'image correctement sans obtenir de PNG blanc : à Partir d'Office 2016

' Copier la forme sous forme d'image (bitmap)
shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture

' Astuce : rendre le graphique actif
TempChart.Parent.Activate ' Évite les erreurs d'image blanche

' Coller l'image dans le graphique
TempChart.Paste

Commandes essentielles pour fiabiliser l'exécution :​

1. Vider le presse-papier entre chaque copie pour assurer la disponibilité des données dans le clipboard :
   With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With
2. Introduire une petite pause et permettre à Excel de traiter les événements en arrière-plan :
   Sleep (250) ' Pause de 0.25 secondes
   DoEvents ' Laisse Excel traiter les autres événements

Résultat :​

Avec cette méthode, aucune image blanche n'est générée, même avec un volume important de traitements. L'activation explicite du graphique temporaire et l'utilisation de ces commandes permettent une exportation fiable.

re
pour l'export avec un chart on en a rien fout'tt que ce soit des png,tiff,gif,jpget même des wmf
du moment que tu fait un copypicture et non un simple copy
maintenant on est sur un autre problème avec les VERSIONS SUP A 2007
et j'ai répondu sur un autre forum ICI
EN effet il y a une latence plus importance pour que le clipboard digère les informations
ce qui fait que soit tu a des images blanches soit carrément un plantage
j'ai bien quelques piste au sujet de ce petit bug mais c'est pas bien précis faut dire que microsoft ne m'a pas aidé sur ce point
bref bonne lecture 😉

'Solution : Explication ci-dessous
'   * Sélectionner dynamiquement le dossier de sauvegarde des PNG (Jpg et ou autres)
'   * Verifie si il s'agit d'un Png dans la feuille Excel
'   * Vide l'espace papier
'   * Crée un graphique chart (vide)
'   * Copie chaques PNG dans l'espace papier
'   * fait une pause de 250 milisecondes
'   * laisse excel traité les autres évenements.
'   * CharObj.Activate (Soit "TempChart.Parent.Activate") : Obligatoire aprés les version Excel 2013 pour Evite l'Export PNG Blanc(2016 --->>> Office 365)
'   * Exporter l'image dans le graphique qui contiendra le PNG
'   * Supprimer le graphique temporaire
Option Explicit
'
'  Code complet pour la compatibilité VBA7 et non-VBA7 :
#If VBA7 Then
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
#End If
'
Sub ExporterImagesChoixDossier()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim ImgCounter As Integer
    Dim FolderPath As String
    Dim imgName As String
    Dim CharObj As ChartObject
    Dim TempChart As Chart
    Dim objShell As Object
    Dim hPicAvail As Long
'
    ' Affiche une boîte de dialogue pour choisir un dossier
        Set objShell = CreateObject("Shell.Application")
            FolderPath = objShell.BrowseForFolder(0, "Sélectionnez le dossier où enregistrer les images", 0).Self.Path
'
    ' Si aucun dossier sélectionné, on quitte
        If FolderPath = "" Then
            MsgBox "Le dossier spécifié n'existe pas: L'exportation est annulée. " & FolderPath, vbExclamation
            Exit Sub
        End If
'
    ' Ajoute un séparateur de chemin si nécessaire
        If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
'
    ' Référence à la feuille active
        Set ws = ActiveSheet
'   
    ' Initialiser le compteur d'images
        ImgCounter = 1
'
    ' Parcourt toutes les formes de la feuille active
        For Each shp In ws.Shapes
            ' Vérifie si la forme est une image
                If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then
                '
                ' Vider le presse papier : On vide le clipboard entre chaque copie pour tester vraiment le available
                    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With
                '
                ' Ajouter un graphique temporaire
                    Set CharObj = ws.ChartObjects.Add(Left:=0, Width:=shp.Width, Top:=0, Height:=shp.Height)
                    Set TempChart = CharObj.Chart
                '
                '   Vérifiez que shp.Type renvoie 13 ou 11.
                '   msoLinkedPicture = 11 (Image liée)
                '   msoPicture = 13 (Image insérée)
                '   Les autres types (ex. msoTextBox, msoShape) ne sont pas compatibles.
                '   Debug.Print shp.Type
                '
                ' Copier la forme sous forme d'image (bitmap)
                    shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                '
                ' Coller l'image dans le graphique
                    Sleep (250) 'Pause 0.5 secondes
                    DoEvents ' laisse excel traité les autres évenements.
                    TempChart.Parent.Activate ' Countournement Stop = ' <<< point d'arrêt ( touche F9 )
                    TempChart.Paste ' <<< Point d'arrêt (touche F9) sur cette ligne après Office 2013 /
                '                     (Jusqu'à Office 2013 = Pas besoin de faire un point d'arrêt manuel soit pas d'image blanche)
                '                     (Mais après Office 2013 --> vers Office 365 et versions ultérieures = Image blanche si TempChart.Parent.Activate
                '                      n'est pas défini au préalable "Cf ligne du dessus")                '
                ' Construire le nom du fichier
                    imgName = FolderPath & "Image_" & ImgCounter & ".png"
                '
                ' Chemin
                    'Debug.Print FolderPath & imgName
                '
                ' Exporter l'image du graphique
                    On Error Resume Next
                        TempChart.Export Filename:=imgName, FilterName:="PNG" ' préparation pour le fichier joint attachement
                            If Err.Number = 0 Then
                                ImgCounter = ImgCounter + 1 ' Augmenter le compteur si l'export a réussi
                            Else
                                MsgBox "Erreur lors de l'exportation de l'image : " & Err.Description, vbExclamation
                            End If
                    On Error GoTo 0
                '
                ' Supprimer le graphique temporaire
                    CharObj.Delete
            End If
        Next shp
'   
    ' Message de confirmation
        If ImgCounter > 1 Then
            'MsgBox "Exportation terminée. " & (ImgCounter - 1) & " images exportées vers " & imgPathChoix, vbInformation
            MsgBox ImgCounter - 1 & " images ont été exportées dans " & FolderPath, vbInformation
        Else
            MsgBox "Aucune image n'a été exportée.", vbExclamation
        End If
End Sub

Ps : C'est l'équivalent de l'option dans le format d'image (les différents choix de compression d'image, mais par VBA) ?

ne pas oublier aussi le poids que peut engendrer 1938 images sur le fichier global

un passage moulinette WIA serait le bien venu me semble t-il

si le cœur lui en dis je donnerais volontiers la fonction de réduction de poids lors de l'importation (librairie WIA)

Cdt
Laurent

 

[laurent950]

Bonsoir le forum

une alternative a l'objet : ChartObjects

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hEmfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As Long) As Long
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hEmfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As Long) As Long
#End If

Const CF_ENHMETAFILE As Integer = 14 ' Format d'image dans le presse-papiers

Sub ExporterImages()
    Dim FolderPath As String
    Dim shp As Shape
    Dim hMetaFile As Long
    Dim SavedFilePath As String
    Dim ImgCounter As Integer
    Dim objShell As Object
   
    ' Affiche une boîte de dialogue pour choisir un dossier
    Set objShell = CreateObject("Shell.Application")
    FolderPath = objShell.BrowseForFolder(0, "Sélectionnez le dossier où enregistrer les images", 0).Self.Path
   
    ' Vérifie si un dossier a bien été sélectionné
    If FolderPath = "" Then
        MsgBox "Aucun dossier sélectionné. Exportation annulée.", vbExclamation
        Exit Sub
    End If
   
    ' Ajoute un séparateur de chemin si nécessaire
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
   
    ' Initialiser le compteur d'images
    ImgCounter = 1
   
    ' Parcours toutes les formes de la feuille active
    For Each shp In ActiveSheet.Shapes
        ' Vérifie si la forme est une image
        If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then
            ' Copier la forme sous forme d'image (bitmap)
            shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
           
            ' Ouvre le presse-papiers
            If OpenClipboard(0) Then
                If IsClipboardFormatAvailable(CF_ENHMETAFILE) Then
                    hMetaFile = GetClipboardData(CF_ENHMETAFILE)
                   
                    ' Sauvegarde l'image si elle est disponible
                    If hMetaFile <> 0 Then
                        'SavedFilePath = FolderPath & "Image_" & ImgCounter & ".emf" ' Origine
                        SavedFilePath = FolderPath & "Image_" & ImgCounter & ".jpg" ' Modifier volontairement en .jpg
                        If CopyEnhMetaFileA(hMetaFile, SavedFilePath) <> 0 Then
                            Debug.Print "Image enregistrée avec succès : " & SavedFilePath, vbInformation
                        Else
                            MsgBox "Erreur lors de l'enregistrement de l'image.", vbExclamation
                        End If
                        DeleteEnhMetaFile hMetaFile
                    Else
                        MsgBox "Impossible d'obtenir les données du presse-papiers.", vbExclamation
                    End If
                End If
                CloseClipboard
            Else
                MsgBox "Impossible d'ouvrir le presse-papiers.", vbExclamation
            End If
           
            ' Incrémentation du compteur d'images
            ImgCounter = ImgCounter + 1
        End If
    Next shp
'
    ' Message de confirmation
        If ImgCounter > 1 Then
            'MsgBox "Exportation terminée. " & (ImgCounter - 1) & " images exportées vers " & imgPathChoix, vbInformation
            MsgBox ImgCounter - 1 & " images ont été exportées dans " & FolderPath, vbInformation
        Else
            MsgBox "Aucune image n'a été exportée.", vbExclamation
        End If
End Sub

Ps : Lien vers autres solution https://excel-downloads.com/threads...e-cellule-vers-dossier.20086089/post-20677332