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]

Bon je confirme mon intuition shell.application fusionne le fichier et la version en instant T

alors comme fileCopy me renvoie enterdit on passe par ce punaise de punaise de fso gros lourdaud
et la ça marche plus de problème

Option Explicit
Sub Export_PhotosVPat()
    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)
    'FileCopy ThisWorkbook.FullName, sourceZip
    CreateObject("Scripting.FileSystemObject").CopyFile ThisWorkbook.FullName, sourceZip, True  'OverWrite
    'suppression des fichier existants si le dossier existe
    If Dir(DestFolderimage, vbDirectory) <> "" Then Kill DestFolderimage & "\*.*": RmDir DestFolderimage

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

    'on va extraire le dossier "media" du zip qui contient toute les images a la racine du classeur
    'chemin du dossier "media" dans le zip
    folderZipimage = UnZipeur.Namespace(sourceZip & "\xl").Items.Item("media").Path
    bm.TrackByName "Unzip Images"
    '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
    'extraction du vmlDrawing1.vml.rels
    UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VMLREL)
    drawing1VMLREL = DestFolderimage & "\vmlDrawing1.vml.rels"
    bm.TrackByName "Unzip VMLREL"
    drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").Items.Item("vmlDrawing1.vml").Path
    UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VML)
    drawing1VML = DestFolderimage & "\vmlDrawing1.vml"
    Set UnZipeur = Nothing
    bm.TrackByName "Unzip VML"
    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
    bm.TrackByName "Copier Images"
   ' Set docXML = CreateObject("MSXML2.DOMDocument")
   ' docXML.async = False
    'x=freefile:open ddddd for input as #x:
  '  docXML.Load drawing1VMLREL
  '  Set relationships = docXML.getelementsbytagname("Relationship")
  '  For Each Elem In relationships
  '      Index = Val(Replace(Elem.getAttribute("Id"), "rId", ""))
  '      Image = ThisWorkbook.Path & Replace(Elem.getAttribute("Target"), "..", "")
  '      Name Image As DestFolderimage & "\" & [Tbl_Invendus[Désignation]].Cells(Index) & ".jpg"
  '  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
    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:shape")
    For Each node In nodes
       shapeId = Right(node.getAttribute("id"), 4)
       relId = node.ChildNodes(0).getAttribute("o: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

bon ben voila a deux on la vaincu le shell capricieux
si on veux l'instan T je pense qu'un simple save pourrait faire l'affaire

voila voila
punaise il m'a fait courrir celui là
punaise,punaise,punaise!!!!!!!

 

[patricktoulon]

maintenant que l'on a avancer sur ce point est ce que tu veux que je te montre quelque chose ?

 

[jurassic pork]

non pareil chez moi je l'ai retelecharger ouvert et lancer ta version avec powershell
Regarde la pièce jointe 1212219

Ben flute alors. En tout cas moi ce que je peux dire c'est qu'avec mon Excel 2016 32 bits sous Windows 11 , les 2 macros fonctionnent correctement et quand j'enregistre le classeur, le fichier vml qui se trouve dans le classeur n'est pas altéré.

 

[patricktoulon]

oui c'est un probleme de version
2016 met en tampon le fichier temporaire dans le Appdata 2010 et 2013 mette le fichier temporaire dans le path du fichier
j'ai compris le truc c'est bon je te fait une video demo si tu veux pour voir le truc

 

[jurassic pork]

oui c'est un probleme de version
2016 met en tampon le fichier temporaire dans le Appdata 2010 et 2013 mette le fichier temporaire dans le path du fichier
j'ai compris le truc c'est bon je te fait une video demo si tu veux pour voir le truc

Non ne t'embête pas le principal c'est d'avoir une explication

 

[patricktoulon]

regarde bien cette image animée

 

[jurassic pork]

Tu es sûr de ce que tu dis parce que chez moi même en Excel 2021 , le fichier temporaire du classeur est toujours dans le chemin où se trouve le classeur ?

 

[patricktoulon]

maintenant regarde peu ça tu va comprendre tout de suite

 

[patricktoulon]

sur mon portable avec l'option montrer les fichier caché 2016 64 bits il n'n"y a pas de fichier transparent".$blablabla.xlsm"qui apparait quand j'ouvre un fichier excel

 

[jurassic pork]

Le problème a l'air d'être connu. Voilà ce que me dit Léo la tête pensante de Brave :

Excel Commentaires et Images Dupliqués
Lorsque vous traitez des fichiers Excel contenant des commentaires et des images, des problèmes peuvent survenir en raison de la duplication o:relid attributs dans les fichiers VML (Vector Markup Language), qui sont utilisés pour stocker des informations de dessin, y compris des images et des commentaires. Voici quelques étapes et idées liées à cette question:

Message d'Erreur: Lors de l'ouverture d'un fichier Excel, vous pouvez rencontrer un message d'erreur indiquant qu'Excel n'a pas pu lire certains contenus et vous demandant si vous voulez essayer de récupérer ce qu'il peut. Cela se produit souvent en raison de fichiers VML corrompus, en particulier lorsqu'il y a plusieurs occurrences du même attribut sur une balise donnée.
Processus de Récupération: Pour récupérer le fichier, Excel tentera de réparer ou de supprimer le contenu illisible. Il pourrait enlever des pièces comme /xl/drawings/drawing1.xml ou /xl/drawings/vmlDrawing2.vml, qui contiennent des formes de dessin et des commentaires.
Cause de la Corruption: La corruption est souvent causée par des changements qui forcent la renumérotation des images existantes, comme supprimer une ligne avec un commentaire contenant une image. Cela peut conduire à dupliquer rId valeurs, qu'Excel ne peut pas gérer correctement.
Manuel Fix: Pour résoudre manuellement le problème, vous pouvez ouvrir le fichier Excel en tant qu'archive zip, accéder au fichier VML problématique (par exemple /xl/drawings/vmlDrawing2.vml), et corriger le dupliqué o:relid attributs. Pour chaque v:fill retirez tout sauf le dernier o:relid attribut. Une fois corrigé, enregistrez le fichier et placez-le de nouveau dans l'archive zip, puis renommez le fichier Excel à son nom d'origine.
Automatisation: Pour les fichiers avec un grand nombre d'images (plus de 600), la fixation manuelle de chacun est peu pratique. Une solution automatisée consiste à utiliser un script ou une macro pour trouver et remplacer tous les éléments sauf le dernier rId pour chaque image du fichier VML. Une méthode consiste à copier le fichier problématique dans un éditeur de texte, en l'enregistrant en tant que .vbs fichier, puis en faisant glisser le fichier corrompu .vml déposez-le pour automatiser le processus de correction.
Ces étapes devraient aider à résoudre le problème des doublons o:relid attributs dans les fichiers Excel contenant des commentaires et des images.

mais on ne sait pas avec quelle version d'Excel cela se produit.
J'ai téléchargé le fichier initial de jeff et j'ai le même phénomène dans mon Excel 2010

 

[patricktoulon]

oui moi aussi j'ai enregistrer et terminé ca ne marche plus
c'est pénible car j'ai trouvé la correspondance avec seulement le vmlDrawing1.vml sans passer par le rels

Option Explicit
Sub Export_PhotosVPat3()
    Dim oApp As Object, sourceZip$, folderZipimage$, DestFolderimage$, drawing1VML$, drawing1VMLREL$, i&, x
    Dim UnZipeur As Object
    '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)
    'FileCopy ThisWorkbook.FullName, sourceZip
    CreateObject("Scripting.FileSystemObject").CopyFile ThisWorkbook.FullName, sourceZip, True 'OverWrite
    'suppression des fichier existants si le dossier existe
    If Dir(DestFolderimage, vbDirectory) <> "" Then Kill DestFolderimage & "\*.*": RmDir DestFolderimage

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

    'on va extraire le dossier "media" du zip qui contient toute les images a la racine du classeur
    'chemin du dossier "media" dans le zip
    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



    drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").Items.Item("vmlDrawing1.vml").Path
    UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VML)
    drawing1VML = DestFolderimage & "\vmlDrawing1.vml"
    Set UnZipeur = Nothing
    Kill sourceZip
    'fin de dézippage les VML compris
    '----------------------------------------------------------
   'renommage des fichiers image par le drawing1VML  SEULEMENT!!!!
    'recupération des correspondences dans un tableau
    x = GetTableForNewName(drawing1VML)
   MsgBox UBound(x)
   For i = 1 To UBound(x)
        If Dir(DestFolderimage & "\" & x(i, 1)) <> "" Then
            Name DestFolderimage & "\" & x(i, 1) As DestFolderimage & "\" & x(i, 2) & ".jpg"
        End If
    Next
    Kill drawing1VML
    MsgBox "Extraction des images de commentaires terminées"
End Sub

Function GetTableForNewName(vml)

     Dim xmldoc, XmlNamespaces, nodes, node, imag, ro, Newname, q&
    Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.async = False
    xmldoc.Load (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:shape")
    If nodes.Length = 0 Then MsgBox "renommage avorté [pas de lecture xml]"
    ReDim t(1 To nodes.Length, 1 To 2)
    For Each node In nodes
        imag = "image" & Replace(node.ChildNodes(0).getattribute("o: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

    Next
GetTableForNewName = t
End Function

 

[jurassic pork]

Bon on va arrêter là car en fait si çà se trouve, ta macro initiale marche avec le fichier complet de jeff si les images sont en ordre. Il nous le dira et en plus il est en excel 2021 et il doit pas y avoir le pb des o:rid dupliqués. Et puis cette manipulation d'extraction d'images de commentaires , il doit pas y avoir grand monde qui en a besoin.

 

[fanch55]

Bonjour à tous,
Je pense que l'on s'écarte grave de la demande initiale à laquelle a répondu efficacement @laurent950 au post #2 .
Sa solution est bien adaptée à l'export de fichier au format Jpg .
La durée d'exécution pour 5 images est de 1,12 secondes . et de 2,12 secondes pour 25 images ( excel 2021/64 bits et 32 go de mémoire mais c'est identique sur le portable de ma femme qui n'a que 8 go)
Un fichier excel avec trop d'images devient "très" lourd, il est préférable alors de mettre les images en externe avec des liens pour les télécharger au moment voulu ( surement incompatible pour des commentaires je présume.
N'oublions pas que la feuille Liste vide dans l'exemple est surement remplie de fichiers images , quelle incidence sur l'analyse et le traitement des fichiers dézippés, je ne suis pas sûr que cela en vaille la peine sauf pour curiosité .
Ci-dessous la version de @laurent950 pour la table structurée de Jeff .

Option Explicit
Sub Export_Photos()
    Dim Cel As Range, Ccom As Comment, Fname As String, Cho As ChartObject
    Dim I, T1, T2
    On Error Resume Next
        MkDir ThisWorkbook.Path & "\JPG_INV"
    On Error GoTo 0
    Application.ScreenUpdating = False
    T1 = Now: Debug.Print "Start", T1
    For Each Cho In ActiveSheet.ChartObjects ' par sécurité
        If Cho.Name = "Tampon" Then Cho.Delete: Exit For
    Next
    For I = 1 To 1
        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) & "(" & I & ").jpg"
                Ccom.Visible = True
                With ActiveSheet.ChartObjects.Add(0, 0, Ccom.Shape.Width, Ccom.Shape.Height)
                    .Activate
                    .Name = "Tampon"
                    Ccom.Shape.CopyPicture
                    .Chart.Paste
                    .Chart.Export Fname, "jpeg"
                    .Delete
                End With
                Ccom.Visible = False
            End Select
        Next
    Next
    T2 = Now: Debug.Print "End", T2, "durée: " & Format(T2 - T1, "s.mm")
End Sub

 

[patricktoulon]

ouais tu as raison ,je crois que le renommage c'est mort
c'est vrai que ma fonction initiale toute petite fonctionne très bien la tienne aussi d'ailleurs juste un peu plus long (powershell non synchro) mais pour l'extraction ça marche
d'ailleurs avec ton fichier modifier 6 commentaire au lieu de 5 je n'ai que 5 images dans media

@fanch55 non tu n'y es pas du tout avec la fonction de Laurent
1° les fichiers image sont plus gros en terme de poids
2° et si on teste 25 images c'est même pas la peine on est loin de ce qu'on obtient avec la simple extraction du dossier media
alors peut être que chez toi c'est rapide mais teste la simple extraction sans renommage tu verra
je dis bien la simple extraction

simple extraction
1° le poids des jpg(ou autres) est beaucoup moins lourd
2° il n'y a pas de doublons
3° le format, la qualité et tout y cointi c'est l'original

tiens la simple extraction

Option Explicit
Sub Export_PhotosVPat3()
    Dim oApp As Object, sourceZip$, folderZipimage$, DestFolderimage$, drawing1VML$, drawing1VMLREL$, i&, x
    Dim UnZipeur As Object
    '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)
    'FileCopy ThisWorkbook.FullName, sourceZip
    CreateObject("Scripting.FileSystemObject").CopyFile ThisWorkbook.FullName, sourceZip, True 'OverWrite
    'suppression des fichier existants si le dossier existe
    If Dir(DestFolderimage, vbDirectory) <> "" Then Kill DestFolderimage & "\*.*": RmDir DestFolderimage

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

    'on va extraire le dossier "media" du zip qui contient toute les images a la racine du classeur
    'chemin du dossier "media" dans le zip
    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

    MsgBox "Extraction des images de commentaires terminées"
End Sub

voila ce qu'un timer me donne

comme je l'ai dit y a pas photo

 

[patricktoulon]

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 😉