XL 2021 Extraction images depuis commentaire de cellule vers dossier.

[jeff1494]

Bonjour à toutes et tous;

J'ai un fichier contenant plusieurs feuilles, dont une nommée "INVENDUS" qui contient une liste d'objets.
Une ligne par objet, et en colonne 2 j'ai la description de l'objet qui contient en commentaire une photo de l'objet.

Je voudrais par macro , pour chaque ligne pouvoir extraire la photo contenue en colonne 2, et la sauvegarder dans un dossier que je nomme "JPG_INV", avec comme nom la valeur de la cellule A de la ligne, et une extension ".jpg".

Pour ce faire j'ai récupéré une macro donnée par @patricktoulon sur un autre forum dans un message dont voici le lien (message #15).
Je l'ai placé dans un module nommé "Export_Images".

J'ai juste adapté le code pour correspondre à mes besoins, à priori rien qui ne puisse changer le fonctionnement de la macro.

Le résultat de l'exécution de cette macro, est que je crée bien les images dans le répertoire défini, mais juste la première images qui est affichée comme un carré blanc dans l'explorateur de Windows.

Donc si jamais @patricktoulon passait par là, je lui serais reconnaissant de bien vouloir m'aider à comprendre pourquoi la première image reste comme un carré blanc, alors que les suivantes sont correctement créées. Mais si une autre personne a une idée du pourquoi du comment je suis preneur.

A toutes fins utiles je vous joins un exemple du fichier que j'utilise.

D'avance je remercie tous ceux ou celles qui voudront bien perdre un peu de leur temps pour m'aider.
Bonne journée à toutes et tous.

 

[patricktoulon]

ho ben moi je ne m'enbête pas avec ça je le fait automatiquement pour le png
basé sur mon module png dont je parlais tout a l'heure qui est basé sur le travail de Philipp Stiefel

VBA - Clipboard Class

Discussion of a VBA class module to retrieve text or file content from the clipboard

codekabinett.com

la en png c'est instantané
je copypicture le shape du comment je paste sur feuille je copy tout court la new picture que je vient de coller et je la delete
terminé

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'function  de cature d'object(range, shapes ,pictures,etc) et sauvegarde en pngFile
'patricktoulon : basé sur le travail de Philipp Stiefel,https://codekabinett.com/rdumps.php?Lang=2&targetDoc=vba-clipboard-file-content
'jurassic pork
#If VBA7 Then
    #If Win64 Then
        ' Déclarations pour VBA 7 64 bits
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As LongPtr) As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
        Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
        Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
        Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
        Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
        Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
    #Else
        ' Déclarations pour VBA7 32 bits
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
        Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
        Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
        Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
        Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
        Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    #End If
#Else
    ' Déclarations pour VBA 6 (32 bits uniquement)
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If


'Sub testavecshape()
'    SaveObjToPngFile ActiveSheet.Shapes("boule"), Environ("userprofile") & "\desktop\output.png"
'End Sub

'Sub testavecrange() 'ne fonctionne pas avec les range
'    SaveObjToPngFile [A1:F5], Environ("userprofile") & "\desktop\output2.png" ', True'le 3eme argumen(true/false) pour laisser la transparence pour les range
'End Sub

Sub Export_Photos3()
    sourceZip = ThisWorkbook.Path & "\zzz.zip"
    destinationFolder = ThisWorkbook.Path & "\mes images"
    If Dir(destinationFolder, vbDirectory) = "" Then MkDir destinationFolder
    Application.ScreenUpdating = False
    With ThisWorkbook.Sheets("INVENDUS")
        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            If Not .Cells(i, 2).Comment Is Nothing Then
                If .Cells(i, 2).Comment.Shape.Fill.Type = 6 Then
                    .Cells(i, 2).Comment.Visible = True
                    SaveObjToPngFile .Cells(i, 2).Comment.Shape, destinationFolder & "\" & .Cells(i, 2).Value & ".png"
                    .Cells(i, 2).Comment.Visible = False
                End If
            End If
        Next
    End With
End Sub



Public Function SaveObjToPngFile(obj As Object, lPath As String, Optional RangeTransparency As Boolean = False) As Variant
    Dim i&, hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte

    obj.CopyPicture ' on reste en xlpicture par defaut(la capture est de meilleure qualité)
    ActiveSheet.Paste 'on recole sur la feuille

    Selection.Copy 'on recopie la capture donc une image (copy tout court pour disposer des formats dans le clipboard)
    Selection.Delete 'on peut supprimer l'image temporaire
    Do Until IsClipboardFormatAvailable(14) > 0 Or i > 1000: i = i + 1: DoEvents: Loop


    dataFormat = RegisterClipboardFormatW(StrPtr("PNG"))

    If Not CBool(OpenClipboard(0)) Then MsgBox "L'Ouverture tu ClipBord a échoué": SaveObjToPngFile = False: Exit Function

    If Not CBool(IsClipboardFormatAvailable(dataFormat)) Then MsgBox "Aucun Png dispo dans le clipboard": SaveObjToPngFile = False: Exit Function

    hClipMemory = GetClipboardData(dataFormat)

    If Not CBool(hClipMemory) Then MsgBox "Aucun Stream de Png dispo dans le clipboard": SaveObjToPngFile = False: Exit Function

    memSize = GlobalSize(hClipMemory)

    lpClipMemory = GlobalLock(hClipMemory)

    If CBool(lpClipMemory) Then

        ReDim tmpBuffer(0 To memSize - 1) As Byte

        Call CopyMemory(VarPtr(tmpBuffer(0)), lpClipMemory, memSize)

        apiRetVal = GlobalUnlock(hClipMemory)
    Else
        MsgBox " Récupération du STREAM du png a echoué": Exit Function
    End If

    Open lPath For Binary Access Write As #1: lWritePos = 1: Put #1, 1, tmpBuffer: Close #1

    SaveObjToPngFile = lPath
    EmptyClipboard
    CloseClipboard

End Function

et voilah!!! juste oun péty peu d'o chode 😉

si avec ça il n'a pas de solution qu'il le jette son fichier 🤣🤣🤣

 

[fanch55]

Bonsoir à tous,
Sinon avec seulement Powershell ( l'autoriser via le pare-feu maison pour le classeur )

Option Explicit
Sub Export_Photos()
    Dim Cel As Range, Ccom As Comment, Fname As String
    On Error Resume Next
        MkDir ThisWorkbook.Path & "\JPG_INV"
    On Error GoTo 0
    Application.ScreenUpdating = False
    For Each Cel In [Tbl_Invendus[Désignation]]
        Set Ccom = Cel.Comment
        Select Case True
        Case Ccom Is Nothing
        Case Not Ccom.Shape.Fill.Type = msoFillPicture
        Case Else
            Fname = "'" & ThisWorkbook.Path & "\JPG_INV\" & Cel.Offset(, -1) & ".jpg'"
            Ccom.Visible = True
            Ccom.Shape.CopyPicture xlScreen, xlBitmap
            ' nota: rajouter -noexit pour voir pourquoi la sauvegarde ne se fait pas
            CreateObject("WScript.Shell").Run "powershell (get-clipboard -format image).save(" & Fname & ")", 7, True
            Ccom.Visible = False
        End Select
    Next
End Sub

 

[patricktoulon]

re
nickel @fanch55
c'est juste un peu long

 

[fanch55]

re
nickel @fanch55
c'est juste un peu long

Salut Pat, pour 25 images de tableau, c'est moins de 2 secondes mais j'avoue que j'ai 32go de mémoire. ... j'ai pas testé plus

 

[patricktoulon]

a oui par ce que moi avec mes 8 giga ben les deux secondes suffisent pas pour les 5 images
peut être peut tu trouver un accélérateur car c'est une bonne solution aussi
car on utilise là aussi des chose que tout les windows ont aujourd'hui
je vais me décider a changer mes mémoires moi 🤣 🤣 🤣

 

[jurassic pork]

cela devrait etre instantané maintenant

hello,
le souci avec le code de laurent du post #32

1. Il ne désactive pas les erreurs sur le Mkdir ce qui fait que si le répertoire existe çà plante.
2. Il renomme ses fichiers emf en jpg mais en fait ce sont des emf si bien qu'avec un lecteur d'images cela ne fonctionne pas
3. Les fichiers emf sont 10 fois plus gros que les jpg ( ex jpg = 60k emf = 370k)
4. Si les fichiers images existent déjà il y a une erreur.
5. On ne peut pas supprimer les fichiers images par l'explorateur windows tant que le classeur est ouvert (fichiers occupés par Excel)

Laurent j'ai vu que tu as mis ton code dans une autre discussion , si il y a des corrections à faire dans ton code n'oublie pas cette discussion.

Ami calmant, J.P

 

[jurassic pork]

Hello,
La méthode du post #36 de patricktoulon m'a donné une idée.
Le souci avec sa méthode c'est qu'il utilise toujours le presse-papiers et que les fichiers images résultant sont des png qui sont plus gros que des jpeg (300k au lieu de 60k).
En fait dans le classeur de jeff toutes les images originales sont présentes dans le répertoire xl/media et sont des fichiers jpeg :

Voici le principe de ma nouvelle méthode qui n'utilise pas le presse-papiers.
1 - on copie le classeur dans un fichier avec une extension zip
2 - on décompresse à l'aide de Powershell ce fichier zip dans un répertoire temporaire
3 - Le souci maintenant c'est de savoir quelle image correspond à quel objet car il n'y a pas de correspondance directe.
4 - Pour cela il faut analyser deux fichiers xml qui se trouve dans le zip :
Le fichier vmlDrawing1.vml qui donne la correspondance entre le nom de l'objet et son id
Le fichier vmlDrawing1.vml.rels qui donne la correspondance entre l'id de l'objet et le nom de l'image
5 - Pour faire la corrélation entre les deux fichiers on utilisera un dictionnaire.
6 - On copie les fichiers images vers le répertoire de destination en les renommant avec le nom de l'objet

Sub Export_PhotosDirect()
    Dim FSO As Object, SourceFile$, DestFile$, ZipPath$, XmlNamespaces$
    Dim fileName$, objName$
    Dim xmlDoc As Object, nodes As Object, node As Object, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    MkDir ThisWorkbook.Path & "\JPG_INV"
    On Error GoTo 0

    SourceFile = ThisWorkbook.FullName
    DestFile = ThisWorkbook.FullName & ".zip"
    DestImages = ThisWorkbook.Path & "\JPG_INV\"
    ZipPath = Environ$("temp") & "\xlsmzip"
    Call FSO.CopyFile(SourceFile, DestFile, True) 'OverWrite
    CreateObject("WScript.Shell").Run "powershell Expand-Archive " & _
                                       DestFile & " -DestinationPath " & ZipPath, 7, 2
    xmlDoc.Load ZipPath & "\xl\Drawings\vmlDrawing1.vml"
    XmlNamespaces = "xmlns:v='urn:schemas-microsoft-com:vml' xmlns:o='urn:schemas-microsoft-com:office:office'"
    xmlDoc.SetProperty "SelectionNamespaces", XmlNamespaces
    Set nodes = xmlDoc.SelectNodes("//v:fill")
    For Each node In nodes
      Debug.Print node.getAttribute("o:relid"), node.getAttribute("o:title")
      dict.Add node.getAttribute("o:relid"), node.getAttribute("o:title")
    Next
    xmlDoc.Load ZipPath & "\xl\Drawings\_rels\vmlDrawing1.vml.rels"
    Set nodes = xmlDoc.SelectNodes("//Relationship")
        For Each node In nodes
             fileName = FSO.GetFileName(node.getAttribute("Target"))
             objName = dict(node.getAttribute("Id"))
             Debug.Print node.getAttribute("Id"), fileName, " ---> " & objName
             FSO.CopyFile ZipPath & "\xl\media\" & fileName, _
             DestImages & objName & ".jpg", True
        Next
   FSO.DeleteFolder ZipPath
   Kill DestFile
   Set FSO = Nothing: Set dict = Nothing: Set nodes = Nothing: Set xmlDoc = Nothing
End Sub

Voici ce que j'obtiens en message de Debug dans la fenêtre d'exécution :

rId1 OBJ006
rId2 OBJ008
rId3 OBJ009
rId4 OBJ010
rId5 OBJ013
rId3 image3.jpeg ---> OBJ009
rId2 image2.jpeg ---> OBJ008
rId1 image1.jpeg ---> OBJ006
rId5 image5.jpeg ---> OBJ013
rId4 image4.jpeg ---> OBJ010

Attention un même fichier image peut correspondre à plusieurs objets (duplication d'images) -> Vérifier que le nombre d'objets correspond au nombre d'images. Il faut peut être aussi filtrer ce que l'on copie car il peut y avoir des images autres que celles que l'on veut extraire.

Ami calmant, J.P

 

[patricktoulon]

re bonjour @jurassic pork oui c'est vrai j'aurais pu les récupérer directement
c'est encore plus rapide puisque je fait juste un savecopyas du classeur lui même

 

[fanch55]

a oui par ce que moi avec mes 8 giga ben les deux secondes suffisent pas pour les 5 images
peut être peut tu trouver un accélérateur car c'est une bonne solution aussi
car on utilise là aussi des chose que tout les windows ont aujourd'hui
je vais me décider a changer mes mémoires moi 🤣 🤣 🤣

Bizarre, ce matin, je fais l'export plusieurs fois et cela me prend systématiquement 7 à 8s pour 25 images .
Du coup j'ai changé la méthode d'appel du shell

CreateObject("WScript.Shell").Run Cmd, vbHide, True
' par
Shell Cmd, vbHide

Surprise, totalement différent en temps :

 

[patricktoulon]

re chez moi c'est un peu plus long et c'est la dernière photo qui est copiée 5 fois
a moins que j'ai fait une erreur dans le code

Option Explicit
Sub Export_Photos4()
    Dim Cel As Range, Ccom As Comment, Fname As String, cmd
    On Error Resume Next
        MkDir ThisWorkbook.Path & "\JPG_INV"
    On Error GoTo 0
    Application.ScreenUpdating = False
    For Each Cel In [Tbl_Invendus[Désignation]]
        Set Ccom = Cel.Comment
        Select Case True
        Case Ccom Is Nothing
        Case Not Ccom.Shape.Fill.Type = msoFillPicture
        Case Else
            Fname = "'" & ThisWorkbook.Path & "\JPG_INV\" & Cel.Offset(, -1) & ".jpg'"
            Ccom.Visible = True
            Ccom.Shape.CopyPicture xlScreen, xlBitmap
            ' nota: rajouter -noexit pour voir pourquoi la sauvegarde ne se fait pas
            cmd = "powershell (get-clipboard -format image).save(" & Fname & ")"
            Shell cmd, vbHide
            
            Ccom.Visible = False
        End Select
    Next
End Sub

 

[jurassic pork]

Hello Fanch55 et patricktoulon,
Fanch55 j'ai regardé les fichiers que tu génères : ils font environ 300Ko et en fait ce sont des PNG (Editer avec NotePad++ on voit le PNG au début du fichier)
Ami calmant, J.P

 

[fanch55]

Hello Fanch55 et patricktoulon,
Fanch55 j'ai regardé les fichiers que tu génères : ils font environ 300Ko et en fait ce sont des PNG (Editer avec NotePad++ on voit le PNG au début du fichier)
Ami calmant, J.P

Tout à fait je l'ai vu également, je n'ai pas réussi à déterminer qui le transforme en PNG, le powershell ou le copypicture ( un gros soupçon quand même pour le dernier ) .

 

[patricktoulon]

re
réponse simple pour @fanch55
le copypicture(argument ou pas) met a dispo dans le clipboard un wmf et un png
c'est d'ailleurs pour ça que quand on sauve en html on a 2 version de chaque images a chaque fois
le copy tout court met a dispo un png

 

[patricktoulon]

par contre entendons nous bien le png est basé sur le bitmap(format très lourd(X10 à peu près))

 

[fanch55]

Bizarre, ce matin, je fais l'export plusieurs fois et cela me prend systématiquement 7 à 8s pour 25 images .
Du coup j'ai changé la méthode d'appel du shell

CreateObject("WScript.Shell").Run Cmd, vbHide, True
' par
Shell Cmd, vbHide

Surprise, totalement différent en temps :
Regarde la pièce jointe 1211996

Oublier ce remplacement, en fait, le code continue sans que le shell ait fini, d'où la vitesse d'execution mais powershell copie ce qu'il trouve dans le clipboard a l'instant T, on a alors des images en doubles ou non correspondantes. J'ai bien sûr tenté d'attendre la fin du processus shell par wmi, mais le temps d'exécution devient exécrable 🫣