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.

 

[fanch55]

j'oubliais laurent fait du 100 x 100 pour la taille des image
déjà on est pas dans le bon ratio
et en plus c'est petit par rapport a la taille originale c'est sur que 100 sur 100 c'ça doit pas être bien lourd dans le clipboard
j'avais d'ailleurs apporté la correction et là c'était plus le même jambon +5 sec sur 30 images

les méthodes zip and unzip ne copient pas on déplace un dossier c'est tout 😉

C'est vrai, les images dézippées sont conformes à l'original .
Il faut sauvegarder le classeur avant le dézippage s'il y a eu des modifs .
Le dossier contient toutes les images du classeur . Mais si tu veux reconstruire les liens ....

 

[patricktoulon]

l faut sauvegarder le classeur avant le dézippage s'il y a eu des modifs .

c'est ce que je disais plus haut

. Mais si tu veux reconstruire les liens ....

ben oui c'est la dessus que l'on travaillaient @jurassic pork et moi justement

 

[patricktoulon]

et le must
quand je dis conforme à l'original c'est pas celui qui a est dans le classeur mais bien l'original qui a été insérer dans le classeur
ça répond a une question qui a été posée récemment peut on récupérer l'image originale
d’ailleurs cette question a été posée plusieurs fois de différentes manières
j'ai toujours répondu que c’était un bitmap et que c’était cuit alors que je fais du customUI tout les jours
zip/rezip

 

[laurent950]

Bonjour @patricktoulon @jurassic pork @fanch55

Problème :
Le fichier vmlDrawing1.vml devient corrompu à partir de cette ligne : If Not relsDoc.Load(relsPath) Then

Si un point d'arrêt est placé sur cette ligne (If Not relsDoc.Load(relsPath) Then),
et que tu ouvres vmlDrawing1.vml avec Notepad++ et que tu le corriges manuellement (en l'enregistrant et le fermant),
le code reprend correctement à la ligne suivante : Set relNodes = relsDoc.getElementsByTagName("Relationship")

Questions :

• L'erreur se produit-elle au moment du chargement du fichier via relsDoc.Load(relsPath) ?
• OU
• Est-ce que l'erreur se produit lorsque le dossier ZIP est créé ou seulement au moment de la création du fichier compressé ?
• <v:fill o:relid="rId1" o:relid="rId1" o:relid="rId1" o:relid="rId1" o:relid="rId1"
• il y a 5 fois o:relid="rId1 mais il y a aussi 5 .Jpeg dans les commentaires ? cela ne semble pas liée !
• avec le même fichier et un commentaire et une image = même soucis
• <v:fill o:relid="rId1" o:relid="rId1" o:relid="rId1" o:relid="rId1" o:relid="rId1"
• donc un commentaire pour une image jpeg = il y a toujours 5 fois o:relid="rId1
• a suivre !

Solution envisagée :

Est-il possible d'intercepter le fichier en amont "vmlDrawing1.vml" le sauvegarder quelque part avant qu'il ne devienne corrompu par la VBA. L'idée serait de substituer son contenu par le fichier propre (au moyen de VBA) sans le corrigé (manuellement au point d'arrêt de la macro : If Not relsDoc.Load(relsPath) Then), au lieu de relancer la macro (Manuellement à ce point d'arrêt : pour cause de correction de ce fichier corrompu : vmlDrawing1.vml) puis à partir de cette étape la macro ce poursuit.
Mais je ne sais pas comment implémenter cela précisément.

Repérage ou ce situe la Problématique dans le code ci-dessous :

' Charger le fichier RELS
Set relsDoc = CreateObject("MSXML2.DOMDocument")
relsDoc.async = False
If Not relsDoc.Load(relsPath) Then ' Ici faire un point d'arret et nettoyer le fichier vmlDrawing1.vml avant de reprendre
MsgBox "Erreur lors du chargement du fichier RELS: " & relsDoc.ParseError.Reason, vbCritical
Exit Sub
End If
Set relNodes = relsDoc.getElementsByTagName("Relationship")

tous le code ? ci-dessous en cours de constructions non finalisé.

Option Explicit

Sub ExtraireImagesDepuisClasseurOuvert()
    ' =====================================================
    ' Partie 1 : Extraction du classeur en ZIP et extraction des fichiers
    ' =====================================================
    Dim ws As Worksheet               ' Feuille "INVENDUS"
    Dim Plg As Range                  ' Plage des cellules à parcourir (B2:B dernière ligne)
    Dim Cell As Range                 ' Variable représentant chaque cellule de la plage
    Dim lastRow As Long               ' Dernière ligne utilisée dans la colonne B
    Dim CheminClasseur As String      ' Chemin complet du classeur ouvert
    Dim CheminZip As String           ' Chemin complet du fichier ZIP à créer
    Dim DossierTemp As String         ' Dossier temporaire d'extraction
    Dim DossierMedia As String        ' Chemin vers le sous-dossier "xl\media" extrait
    Dim fso As Object                 ' FileSystemObject pour la manipulation des fichiers/dossiers
    Dim sh As Object                  ' Shell.Application pour extraire le contenu du ZIP
    Dim NSdest As Object, NSzip As Object ' Objets Namespace pour destination et source ZIP
    Dim t As Single                   ' Variable pour mesurer le temps d'attente
 
    ' Définition des chemins
    CheminClasseur = ThisWorkbook.FullName
    CheminZip = ThisWorkbook.Path & "\TempClasseur.zip"
    DossierTemp = ThisWorkbook.Path & "\ExtractionTemp\"
    DossierMedia = DossierTemp & "xl\media\"
 
    ' Création de l'objet FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    ' Supprimer le dossier temporaire existant (s'il existe)
    On Error Resume Next
    If fso.FolderExists(DossierTemp) Then fso.DeleteFolder DossierTemp, True
    On Error GoTo 0
 
    ' Créer le dossier temporaire
    fso.CreateFolder DossierTemp
 
    ' Copier le classeur ouvert dans un fichier ZIP
    fso.CopyFile CheminClasseur, CheminZip, True
 
    ' Attendre que le fichier ZIP soit créé (max 5 secondes)
    t = Timer
    Do While Not fso.FileExists(CheminZip)
        DoEvents
        If Timer - t > 5 Then
            MsgBox "Le fichier ZIP n'a pas été créé dans les 5 secondes.", vbCritical
            Exit Sub
        End If
    Loop
 
    ' Créer l'objet Shell.Application pour extraire le contenu du ZIP
    Set sh = CreateObject("Shell.Application")
    Set NSdest = sh.Namespace(fso.GetAbsolutePathName(DossierTemp))
    Set NSzip = sh.Namespace(fso.GetAbsolutePathName(CheminZip))
 
    ' Extraire le contenu du ZIP dans le dossier temporaire
    NSdest.CopyHere NSzip.Items, 16
 
    ' Attendre que le dossier "xl\media" apparaisse (max 10 secondes)
    t = Timer
    Do While Not fso.FolderExists(DossierMedia)
        DoEvents
        If Timer - t > 10 Then Exit Do
    Loop
 
    ' Vérifier l'extraction
    If fso.FolderExists(DossierMedia) Then
        MsgBox "Extraction des images réussie dans le dossier : " & DossierMedia, vbInformation
    Else
        MsgBox "Aucune image trouvée dans 'xl\media'.", vbCritical
        Exit Sub
    End If
 
    ' =====================================================
    ' Partie 2 : Renommage des images en fonction des cellules
    ' =====================================================
    ' Nous allons utiliser les fichiers VML et RELS pour retrouver la correspondance.
    Dim vmlPath As String, relsPath As String, mediaPath As String
    Dim xmlDoc As Object, relsDoc As Object
    Dim shapeNodes As Object, relNodes As Object
    Dim shapeNode As Object, relNode As Object
    Dim rId As String, imageName As String
    Dim anchor As String, row As Long, col As Long
    Dim cellText As String
    Dim oldFile As String, newFile As String

    ' Définition des chemins pour les fichiers XML et le dossier des images
    vmlPath = DossierTemp & "xl\drawings\vmlDrawing1.vml"
    relsPath = DossierTemp & "xl\drawings\_rels\vmlDrawing1.vml.rels"
    mediaPath = DossierMedia  ' On utilisera le dossier extrait

    ' Vérifier que les fichiers VML et RELS existent
    If Dir(vmlPath) = "" Or Dir(relsPath) = "" Then
        MsgBox "Fichier VML ou RELS introuvable !", vbCritical
        Exit Sub
    End If

    ' Charger le fichier VML
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False
    If Not xmlDoc.Load(vmlPath) Then
        MsgBox "Erreur lors du chargement du fichier VML: " & xmlDoc.ParseError.Reason, vbCritical
        Exit Sub
    End If
    Set shapeNodes = xmlDoc.getElementsByTagName("v:shape")
 
    ' Charger le fichier RELS
    Set relsDoc = CreateObject("MSXML2.DOMDocument")
    relsDoc.async = False
    If Not relsDoc.Load(relsPath) Then
        MsgBox "Erreur lors du chargement du fichier RELS: " & relsDoc.ParseError.Reason, vbCritical
        Exit Sub
    End If
    Set relNodes = relsDoc.getElementsByTagName("Relationship")
 
    ' Sélectionner la feuille "INVENDUS" (ou la feuille active si approprié)
    Set ws = ThisWorkbook.Worksheets("INVENDUS")
 
    ' Parcourir chaque forme (annotation) dans le fichier VML
    For Each shapeNode In shapeNodes
        ' Récupérer le rId de l'image depuis la balise <v:fill>
        If shapeNode.getElementsByTagName("v:fill").Length > 0 Then
            rId = shapeNode.getElementsByTagName("v:fill")(0).getAttribute("o:relid")
        Else
            GoTo NextShape
        End If
 
        ' Récupérer la position (ancre) pour retrouver la cellule associée
        If shapeNode.getElementsByTagName("x:Anchor").Length > 0 Then
            anchor = shapeNode.getElementsByTagName("x:Anchor")(0).Text
        Else
            GoTo NextShape
        End If
        Dim parts() As String
        parts = Split(anchor, ",")
        If UBound(parts) < 3 Then GoTo NextShape
        row = CLng(parts(2)) + 1  ' Conversion de l'index (0-based) en ligne Excel
        col = CLng(parts(3)) + 1  ' Conversion de l'index (0-based) en colonne Excel
 
        ' Lire le texte dans la cellule correspondante
        cellText = Trim(ws.Cells(row, col).Value)
        If cellText = "" Then GoTo NextShape
 
        ' Trouver le nom de l'image correspondant à ce rId dans le fichier RELS
        imageName = ""
        For Each relNode In relNodes
            If relNode.getAttribute("Id") = rId Then
                imageName = Replace(relNode.getAttribute("Target"), "../media/", "")
                Exit For
            End If
        Next relNode
 
        ' Si un nom d'image a été trouvé, procéder au renommage
        If imageName <> "" Then
            oldFile = mediaPath & imageName
            If Dir(oldFile) <> "" Then
                ' Conserver l'extension d'origine
                Dim ext As String
                ext = Mid(imageName, InStrRev(imageName, ".") + 1)
                newFile = mediaPath & cellText & "." & ext
                ' Renommer le fichier image
                Name oldFile As newFile
            End If
        End If
 
NextShape:
    Next shapeNode
 
    ' Libération des objets
    Set fso = Nothing
    Set sh = Nothing
    Set NSdest = Nothing
    Set NSzip = Nothing
    Set ws = Nothing
    Set xmlDoc = Nothing
    Set relsDoc = Nothing

    MsgBox "Renommage terminé !", vbInformation
End Sub

 

[patricktoulon]

bonsoir laurent à quoi bon sauvegarder le vml before changement si puisque qu'il ne contiendra pas les changement

 

[laurent950]

bonsoir laurent à quoi bon sauvegarder le vml before changement si puisque qu'il ne contiendra pas les changement

Ce fichier pause un soucis, il y a une écriture qui crée des doublons et cela rend non conforme ce fichier qui ne peut être lu par la VBA.

J ai trouvé aucune solution à part nettoyer ce fichier pour poursuivre la VBA

J ai rien trouvé d autres pour le moment !

 

[patricktoulon]

@laurent950
si il ne s'agit que de netoyage a ton service
et comme je me sert uniquement du vml et plus le rel
je te laisse le soin de controler

Sub test()
    GetTableForNewName "C:\Users\patricktoulon\Desktop\vmlDrawing1.vml"
End Sub


Function GetTableForNewName(vml)
    Dim xmldoc, XmlNamespaces, nodes, node, imag, ro, Newname, q&, x&, lines$, z, w
    Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.async = False
    x = FreeFile: Open vml For Input As #x: lines = Input$(LOF(x), #x): Close #x
    lines = Replace(Replace(Replace(lines, "v:", ""), "o:", ""), "x:", "")
    lines = "<xml>" & Split(lines, "</shapetype>")(1)
    For z = 1 To 1000
        For w = 1 To 200
            If Not lines Like "*relid=""rId" & w & Chr(34) & "*" Then Exit For
            lines = Replace(lines, "relid=""rId" & w & Chr(34) & "   relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
            lines = Replace(lines, "relid=""rId" & w & Chr(34) & "  relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
            lines = Replace(lines, "relid=""rId" & w & Chr(34) & " relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
        Next
    Next

    xmldoc.LoadXML lines
    Set nodes = xmldoc.getelementsbytagname("shape")

    If nodes.Length = 0 Then MsgBox "renommage avorté [pas de lecture xml]": Exit Function
    ReDim t(1 To nodes.Length, 1 To 2)
    For Each node In nodes
        imag = "image" & Replace(node.ChildNodes(0).getattribute("relid"), "rId", "") & ".jpg"
        ro = node.ChildNodes(4).ChildNodes(4).text
        Newname = [Tbl_INVENDUS[Désignation]].Cells(ro)
        q = q + 1: t(q, 1) = imag: t(q, 2) = Newname
        MsgBox Chr(34) & imag & Chr(34) & " devient """ & Newname & ".jpg"""
    Next
    GetTableForNewName = t
End Function

 

[patricktoulon]

bonjour à tous
problème réglé
on peut donc travailler dans l’instante

Option Explicit
Sub Export_CommentairesPicturesVPat()
    Dim oApp As Object, sourceZip$, folderZipimage$, DestFolderimage$, drawing1VML$, drawing1VMLREL$, i&
    Dim UnZipeur As Object, bm As New cBenchmark
    'les path
    sourceZip = ThisWorkbook.Path & "\zzz.zip"
    DestFolderimage = ThisWorkbook.Path & "\media"

    ThisWorkbook.SaveCopyAs sourceZip 'zippage du classeur dans son etat actuel(c'est un peu plus long mais a jour)
      'suppression des fichier existants si le dossier existe
    If Dir(DestFolderimage, vbDirectory) <> "" Then
        If Dir(DestFolderimage & "\*.*") <> "" Then Kill DestFolderimage & "\*.*"
        RmDir DestFolderimage
    End If

    '-------------------------------------------------------
    'dézippage by patricktoulon(france)
     Set UnZipeur = CreateObject("Shell.Application")

      folderZipimage = UnZipeur.Namespace(sourceZip & "\xl").Items.Item("media").Path
      
      'extraction du dossier media en entier
    UnZipeur.Namespace(ThisWorkbook.Path & "\").CopyHere (folderZipimage)

    Do While Dir(DestFolderimage, vbDirectory) = "" Or i < 1000: i = i + 1: DoEvents: Loop
    If Dir(DestFolderimage, vbDirectory) = "" Then MsgBox "l 'extraction du dossier media c'est Mal passée" & vbCrLf & "sortie du programe!!": Set oApp = Nothing: Exit Sub

    'chemin du vmlDrawing1.vml.rels
    drawing1VMLREL = UnZipeur.Namespace(sourceZip & "\xl\drawings\_rels").Items.Item("vmlDrawing1.vml.rels").Path
     UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VMLREL)
    drawing1VMLREL = DestFolderimage & "\vmlDrawing1.vml.rels"
     
     drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").Items.Item("vmlDrawing1.vml").Path
    UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VML)
    drawing1VML = DestFolderimage & "\vmlDrawing1.vml"
    corecteurVML drawing1VML
    Set UnZipeur = Nothing
    Kill sourceZip
    'fin de dézippage les VML compris
    '----------------------------------------------------------
    'copier les images
    Dim DictShp As Object, DictFile As Object, Ccom As Object, Cel, Fname$
    Set DictShp = CreateObject("Scripting.Dictionary")
    Set DictFile = CreateObject("Scripting.Dictionary")
    ChargerDicts drawing1VML, drawing1VMLREL, DictShp, DictFile
    bm.TrackByName "ChargerDicts"
    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 = DictFile(DictShp(CStr(Ccom.Shape.id)))
                FileCopy DestFolderimage & "\" & Fname, _
                                            DestFolderimage & "\" & Cel & ".jpg"
        End Select
    Next
        Kill DestFolderimage & "\image*.*"
    Kill drawing1VMLREL
    Kill drawing1VML
    Set DictShp = Nothing: Set DictFile = Nothing
    MsgBox "Extraction des images de commentaires terminées"
End Sub
Sub ChargerDicts(vmlFile, vmlrelFile, DictShp, DictFile)
    Dim fileName$, objName, relId$, shapeId$, XmlNamespaces$, res
    Dim FSO As Object, xmldoc As Object, nodes As Object, node As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.async = False
    res = xmldoc.Load(vmlFile)
    If Not res Then MsgBox ("erreur Lecture fichier xml : " & vmlFile): End
    Set nodes = xmldoc.getelementsbytagname("shape")
    For Each node In nodes
        shapeId = Right(node.getattribute("id"), 4)
        relId = node.ChildNodes(0).getattribute("relid")
        'Debug.Print shapeId,relId
        DictShp.Add shapeId, relId
    Next
    res = xmldoc.Load(vmlrelFile)
    If Not res Then MsgBox ("erreur Lecture fichier xml : " & vmlrelFile): End
    Set nodes = xmldoc.SelectNodes("//Relationship")
    For Each node In nodes
        fileName = FSO.GetFileName(node.getattribute("Target"))
        relId = node.getattribute("Id")
        'Debug.Print relId, fileName
        DictFile.Add relId, fileName
    Next
    Set FSO = Nothing: Set nodes = Nothing: Set xmldoc = Nothing
End Sub
Function corecteurVML(vml)
    Dim xmldoc, nodes, node, imag, ro, x&, lines$, z, w
    Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.async = False
    x = FreeFile: Open vml For Input As #x: lines = Input$(LOF(x), #x): Close #x
    lines = Replace(Replace(Replace(lines, "v:", ""), "o:", ""), "x:", "")
    lines = "<xml>" & Split(lines, "</shapetype>")(1)
    For z = 1 To 1000
        For w = 1 To 200
            If Not lines Like "*relid=""rId" & w & Chr(34) & "*relid=""rId" & w & Chr(34) & "*" Then Exit For
            lines = Replace(lines, "relid=""rId" & w & Chr(34) & "   relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
            lines = Replace(lines, "relid=""rId" & w & Chr(34) & "  relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
            lines = Replace(lines, "relid=""rId" & w & Chr(34) & " relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
        Next
    Next
    x = FreeFile: Open vml For Output As #x: Print #x, lines: Close #x
End Function

 

[fanch55]

Salut Patrick,
Testé ton code avec le classeur fourni : impressionnant . 👍
Ci-joint le classeur avec les lignes des invendus dupliquées, le code se plante ....
Attention, tu renommes tous les médias en Jpg, il peut y en avoir d'autres .

 

[jurassic pork]

Ci-joint le classeur avec les lignes des invendus dupliquées, le code se plante ....
Attention, tu renommes tous les médias en Jpg, il peut y en avoir d'autres .

Hello,
houla, ça se complique , il y a deux fichiers vml dans ton classeur fanch55 :

Les méthodes avec le presse-papier sont peut-être alors plus sûres. Le seul souci avec ces méthodes c'est qu'on a pas les jpeg initiaux. On part du bmp donc sans dégradation par rapport à l'original et on transforme dans un format comme le png qui ne dégrade pas mais plus gros que l'original, le bmp très gros, le jpeg mais il faut alors sauvegarder avec une compression qui ne dégrade pas plus que l'original (on doit avoir à peu près les même tailles que l'original). Mon code qui sauve en jpeg réduit la taille par rapport aux originaux donc doit dégrader plus.

Ami calmant, J.P

 

[fanch55]

Patrick, je viens de tout recommencer:
J'ai repris le classeur originel, mis ton code, dupliqué les lignes des Invendus, rajouter des images dans Liste.
Tout fonctionne correctement ( à part les png renommés en Jpg ), je n'arrive pas à reproduire le problème rencontré . 😵‍💫
@jurassic pork vient de découvrir que j'ai plusieurs fichiers vmf et xml dans le classeur à problème, c'est à l'insu de mon plein gré ....

 

[patricktoulon]

ki a tout cassé encore hein ?
bon on a du png maintenant
punaise vous êtes pas gentil avec moi vous m'en donnez toujours plus 🤣

 

[jurassic pork]

bon on a du png maintenant
punaise vous êtes pas gentil avec moi vous m'en donnez toujours plus 🤣

Hello patrick,
surtout que dans les jpg de jeff dans les métadonnées on peut voir que les jpeg proviennent d'un appareil photo , et cela m'étonnerait qu'il ait glissé des png dans ses commentaires vu qu'il s'agit d'objets photographiés.
Ami calmant, J.P

 

[patricktoulon]

ouaiiiis c'est fanch55 qui veux nous pranker 🤣 🤣
d'autant plus que je ne suis pas sur que l'on puisse mettre du png dans les commentaires ,sur la feuille oui mais pas les comms

 

[fanch55]

ouaiiiis c'est fanch55 qui veux nous pranker 🤣 🤣
d'autant plus que je ne suis pas sur que l'on puisse mettre du png dans les commentaires ,sur la feuille oui mais pas les comms

Si si, jai testé pour voir, il semblerait qu'on peut y mettre tout type d' "image" :
testé les jpg, png , bmp et gif .