XL 2021 Extraction images depuis commentaire de cellule vers dossier.

jeff1494 · 26 Janvier 2025

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.

laurent950 · 26 Janvier 2025

Bonsoir @jeff1494

"Il manquait cela : .Activate"

Pour comprendre ici en Poste #38 : https://excel-downloads.com/threads/export-dimages-renommer-celles-ci.20034890/post-20674531

VB:

Option Explicit

Sub Export_Photos()
    Dim i As Long
    On Error Resume Next
    MkDir ThisWorkbook.Path & "\JPG_INV"
    Err.Clear
'    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets.Add(After:=Sheets("INVENDUS")).Name = "Feuille_Transit"
    
    With Sheets("Feuille_Transit").ChartObjects.Add(0, 0, 100, 100).Chart
        .Parent.Name = "calque"
    End With
    For i = 2 To Sheets("INVENDUS").Cells(Rows.Count, 2).End(xlUp).Row
        If Sheets("INVENDUS").Cells(i, 2).Comment.Shape.Fill.Type = 6 Then
        save_comment_fichier_jpg...

fanch55 · 3 Février 2025

jurassic pork à dit:
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

C'est vrai pour ce cas, mais si on peut étendre le domaine du code, autant le faire tout de suite ( quoique les extensions ne sont pas forcément conformes avec les contenus )

Je dirai plutôt un mobile, un Galaxy J6 .

laurent950 · 3 Février 2025

fanch55 à dit:
C'est vrai pour ce cas, mais si on peut étendre le domaine du code, autant le faire tout de suite ( quoique les extensions ne sont pas forcément conformes avec les contenus )

Bonsoir @patricktoulon @jurassic pork @fanch55 @jeff1494

J'ai revu ma copie est cela devrait être OK pour tous les Format (pris en charge par Excel de Base)

Voir le résultat dans le dossier : Media
Chemin : "C:\Votre chemin\ExtractionTemp\xl\media"

Ps : Excel Transforme de base les images insérer dans les commentaires (tous les formats d'origines ne peuvent etre restitué)
.bmp (c'est pas pris en compte Excel transforme l'extension de base en .png
.Jpg (c'est pas pris en compte Excel le transforme de base en .jpeg
.Gif (c'est pas pris en compte Excel le transforme de base en .jpeg
.Tif (est pris en compte) Extension inchangé
.Jpeg (est pris en compte) Extension inchangé
.Png (est pris en compte) Extension inchangé

Regarder dans le dossier "Media" les Images sont bien renommée au bon format, mais c'est complexe comme code ?
au passage une Regex pour @jurassic pork 🙂

il faut finalisé : (A la relance de la VBA)
si le dossier existe = Suppression du dossier : ExtractionTemp
si le classeur Zip = Suppression du dossier : TempClasseur.zip

en attendant suppression manuellement de ses dossier et classeur ci-dessus
puis relance de la VBA

etc. a suivre.

Extraction images depuis commentaire de cellule vers dossier.

VB:

Option Explicit

' Fonction pour nettoyer le contenu du fichier VML en supprimant les doublons de o:relid
Function CleanVMLContent(fileContent As String) As String
    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
 
    ' Configurer la regex
    ' Cette expression recherche une première occurrence de o:relid="rIdX" suivie d'une ou plusieurs autres occurrences
    ' et remplace tout par la première occurrence.
    regEx.Pattern = "(o:relid=""rId\d+"")(\s+o:relid=""rId\d+"")+"
    regEx.Global = True
    regEx.IgnoreCase = True
 
    ' Remplacer toutes les occurrences répétées par une seule
    CleanVMLContent = regEx.Replace(fileContent, "$1")
End Function

' Procédure pour lire, nettoyer et réécrire le fichier VML
Sub CleanVMLFile(vmlPath As String)
    Dim fso As Object
    Dim fileNum As Integer
    Dim fileContent As String
    Dim cleanedContent As String
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    ' Vérifier que le fichier existe
    If Not fso.FileExists(vmlPath) Then
        MsgBox "Le fichier VML n'existe pas : " & vmlPath, vbCritical
        Exit Sub
    End If
 
    ' Lire le contenu entier du fichier
    fileNum = FreeFile
    Open vmlPath For Input As #fileNum
        fileContent = Input$(LOF(fileNum), #fileNum)
    Close #fileNum
 
    ' Nettoyer le contenu du fichier à l'aide de la fonction CleanVMLContent
    cleanedContent = CleanVMLContent(fileContent)
 
    ' Écrire le contenu nettoyé dans le même fichier (ou dans un fichier temporaire)
    fileNum = FreeFile
    Open vmlPath For Output As #fileNum
        Print #fileNum, cleanedContent
    Close #fileNum
 
    MsgBox "Fichier VML nettoyé et sauvegardé : " & vmlPath, vbInformation
End Sub

' Exemple d'utilisation dans votre flux de traitement
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

    ' ----- Correction du fichier VML pour enlever les attributs dupliqués -----
    Call CleanVMLFile(vmlPath)
 
    ' Charger le fichier VML corrigé
    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"
        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 via <x:Row> et <x:Column> dans le bloc <x:ClientData>
    On Error Resume Next
    row = CLng(shapeNode.getElementsByTagName("x:Row")(0).Text) + 1
    col = CLng(shapeNode.getElementsByTagName("x:Column")(0).Text) + 1
    On Error GoTo 0
    If row = 0 Or col = 0 Then GoTo NextShape
 
    ' 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
            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 · 3 Février 2025

@laurent950
bravo essai réussi mais.:

1° tu extrait la totalité de l'archive
2°un petit oublie pour le cas ou on relance plusieurs fois

VB:

' Créer le dossier temporaire
    If Dir(DossierTemp) <> "" Then fso.GetFolder(DossierTemp).Delete
    fso.CreateFolder DossierTemp

3° comme tu extrait tout il faut aller chercher le dossier dans le dossier temp
4° le zip temporaire n'est pas supprimer ni avant ni apres
5° qui est en fait le 1 c'est que tu copyfile alors que l'on est sensé travailler sur l'instant T

Donc
point fort:
tu maitrise apparemment bien aujourd'hui le regex
pas mal le replace de cette façon
tu reste en shemas xpath propertie
tu n'utilise pas de dico mais deux xmldoc

point faible :
extraction totale ralenti beaucoup le truc
fichier excédant pas supprimé
le dossier des images(media n'est pas directement accessible )
les msgbox qui disent que les etapes reussissent on s'en fou vire ne garde que les negatif

point à discuter
est ce que utiliser des object comme le regex +fso et autres n'est pas un peu lourd ?
je dis ça c'est une reflexion personnelle

une idée
voyant maintenant que les problème et contraintes sont maitrisés je propose que nous réécrivions
ce travail fonction par fonctions
en effet le besoin peut être seulement l'extraction
a fin que si les paramètres de recherche doivent changer dans les xml on se concentre uniquement sur ces parties

et là nous auront bien travaillé

voila voila

jurassic pork · 4 Février 2025

Hello,
Excellent Laurent le nettoyage par regex et l'exploitation simultanée des 2 xml.
J'ai corrigé quelques trucs dans ton code .
1 - Le FSO.DeleteFolder DossierTemp, True ne fonctionner pas à cause du \ que tu as mis à la fin du DossierTemp
et on ne voyait pas l'erreur à cause du On Error Resume Next juste avant
Corrections :

VB:

    DossierTemp = ThisWorkbook.Path & "\ExtractionTemp"
    DossierMedia = DossierTemp & "\xl\media"

et ne pas oublier :

Code:

     ' 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"

D'autre part pour la correction du vml, ce n'est pas la peine de réécrire le vml car on peut charger directement la chaîne dans le xmlDoc (LoadXML)
donc transformer la Sub en fonction :
' Fonction pour lire, nettoyer le fichier VML

Code:

Function CleanVMLFile(vmlPath As String) As String
    Dim FSO As Object
    Dim fileNum As Integer
    Dim fileContent As String
    Dim cleanedContent As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    ' Vérifier que le fichier existe
    If Not FSO.FileExists(vmlPath) Then
        MsgBox "Le fichier VML n'existe pas : " & vmlPath, vbCritical
        Exit Function
    End If
 
    ' Lire le contenu entier du fichier
    fileNum = FreeFile
    Open vmlPath For Input As #fileNum
        fileContent = Input$(LOF(fileNum), #fileNum)
    Close #fileNum
 
    ' Nettoyer le contenu du fichier à l'aide de la fonction CleanVMLContent
    CleanVMLFile = CleanVMLContent(fileContent)
End Function

et pour le chargement dans xmlDoc :

Code:

    ' ----- Correction du fichier VML pour enlever les attributs dupliqués -----
 '   Call CleanVMLFile(vmlPath)
 
    ' Charger le fichier VML corrigé
    Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.async = False
 '   If Not xmlDoc.Load(vmlPath) Then
     If Not xmldoc.LoadXML(CleanVMLFile(vmlPath)) Then
        MsgBox "Erreur lors du chargement du fichier VML: " & xmldoc.ParseError.Reason, vbCritical
        Exit Sub
    End If

Pour la remarque de Patrick concernant la lenteur avec une extraction totale du Zip --> Pas tant que çà
Comparaison entre le temps d'exécution de la dernière macro de Patrick et Celle de Laurent :
Avec le code de Laurent :

Name	Sum of Tics	Percentage	Time Sum
Copie Classeur -> zip	15 063	0,23%	1,51 ms
Extraction Zip	6 447 691	98,80%	645 ms
Chargement premier vml	50 267	0,77%	5,03 ms
Chargement deuxième vml	5 282	0,08%	528 us
Ecriture Fichiers Image	7 538	0,12%	754 us
TOTAL	6 525 841	100,00%	653 ms

Avec le code de Patrick :

Name	Sum of tics	Percentage	Time sum
SaveCopyAs	599 257	7,64%	60 ms
Unzip FolderImage	4 281 513	54,59%	428 ms
Unzip drawing1VMLREL	1 783 426	22,74%	178 ms
Unzip drawing1VML	1 033 571	13,18%	103 ms
Correcteur VML	72 129	0,92%	7,21 ms
ChargerDicts	46 496	0,59%	4,65 ms
Copie Images	26 592	0,34%	2,66 ms
TOTAL	7 842 984	100,00%	784 ms

Les extractions partielles ne sont finalement pas si avantageuses que çà.

Le CopyFile ou le SaveCopyAs sont beaucoup plus lents la première fois qu'on les utilise (3 secondes pour le SaveCopyAs). Après il doit y avoir un effet de cache.
Si on utilise un CopyFile tout simplement sauvegarder le fichier par menu Excel si il y a eu des modifs avant de lancer la macro.

Pour la remarque de Patrick concernant la "lourdeur" d'utiliser les objets regex et fso, la création de ces objets ne prend pas beaucoup de temps , ils sont toujours présents quelque soit l'O.S (sauf Mac) et les versions d'Excel (32 bits et 64 bits) et ils simplifient le code.

Ami calmant, J.P

patricktoulon · 4 Février 2025

re
bonjour @jurassic pork chez moi la différence est enorme (a l'echelle)
ma version juste le temps d'inspirer
la version de laurent 2 sec et demie a peu près
dans la journée quand je reviendrais je regarderais un truc (y a un truc qui me titille)

laurent950 · 4 Février 2025

Bonjour @patricktoulon

patricktoulon à dit:
une idée
voyant maintenant que les problème et contraintes sont maitrisés je propose que nous réécrivions
ce travail fonction par fonctions
en effet le besoin peut être seulement l'extraction
a fin que si les paramètres de recherche doivent changer dans les xml on se concentre uniquement sur ces parties

et là nous auront bien travaillé

Merci pour ton retour détaillé et ta proposition d'amélioration. Je suis totalement ouvert à ce que tu utilises mon code et que tu te l’appropries pour l’optimiser dans l’esprit que tu as décrit. Ton approche méthodique, en revoyant le travail fonction par fonction, est excellente et permettra de mieux isoler les besoins spécifiques, comme l’extraction seule ou la modification des paramètres de recherche dans les XML.

De mon côté, cela me permet aussi d’apprendre et de renforcer mes connaissances en voyant comment tu affines le processus. Je trouve très intéressant de confronter nos approches et de chercher ensemble des solutions plus efficaces.

Bref, je suis partant pour cette refonte plus modulaire, et je te remercie pour ton regard critique et constructif !

Laurent 😀

laurent950 · 4 Février 2025

Bonjour @jurassic pork

Merci beaucoup pour ton aide et ton expertise ! Grâce à tes conseils, le code s’améliore au fil des échanges. C’est toujours un plaisir de te lire et d’enrichir mes connaissances grâce à tes explications. Encore merci pour ton temps et ton partage !

jurassic pork à dit:
Hello,
Excellent Laurent le nettoyage par regex et l'exploitation simultanée des 2 xml.

patricktoulon · 4 Février 2025

re bon j'ai essayé avec saveAs effectivement ca ne marche pas ca doit corrompre plus que l'on croit le vml
alors j'ai mis un save avant le filecopy sinon on a pas les modifs

VB:

  ' Création de l'objet FileSystemObject
   ThisWorkbook.Save
   DoEvents
   Set fso = CreateObject("Scripting.FileSystemObject")

le problème est que si on ne veux pas sauvegarder les modifs c'est un peu chaud
il faudrait examiner minutieusement le modifs (que l'on a certainement pas vu) avec le saveAS du thisworkbook

patricktoulon · 4 Février 2025

bon ben a nous 3 on cartonne
alors
je reprends mon idée d'extraction partielle et oui elle est largement plus rapide
je reprends l'idée de @jurassic pork avec les dicos
je reprend le clean vml de @laurent950
et j'utilise saveAs pour le thisworkbook et avoir l'instant T
pour le regex de @laurent950 je ne modifie pas le vml je recupère le code /le modifie/et la fonction renvoie du code xml
et au lieu de loader un fichier je load le codexml( res = xmlDoc.LoadXML(GetavailableXmlCode(vmlFile)))
ce qui fait que je l'ouvre qu'une fois a la place de 2

VB:

Option Explicit
Sub Export_CommentairesPicturesVPat()
    'fonction et macros  patricktoulon
    Dim oApp As Object, sourceZip$, folderZipimage$, DestFolderimage$, drawing1VML$, drawing1VMLREL$, i&
    Dim UnZipeur As Object, bm As New cBenchmark
     tim = Timer
    '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"
    Set UnZipeur = Nothing
    Kill sourceZip
    'fin de dézippage les VML compris
    '----------------------------------------------------------
    'copier les images
    'fonction et macro @jurassic pork
    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
    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" & vbCrLf
   
End Sub
Sub ChargerDicts(vmlFile, vmlrelFile, DictShp, DictFile)
   '@jurassic pork
    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.LoadXML(GetavailableXmlCode(vmlFile))
    If Not res Then MsgBox ("erreur Lecture fichier xml : " & vmlFile): End
    Set nodes = xmlDoc.getElementsByTagName("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
Function GetavailableXmlCode(vml)
    'issue de la fonction de @laurent950
    Dim x&, lines$, regEx
    x = FreeFile: Open vml For Input As #x: lines = Input$(LOF(x), #x): Close #x
    Set regEx = CreateObject("VBScript.RegExp")

    ' Configurer la regex
    ' Cette expression recherche une première occurrence de o:relid="rIdX" suivie d'une ou plusieurs autres occurrences
    ' et remplace tout par la première occurrence.
    regEx.Pattern = "(o:relid=""rId\d+"")(\s+o:relid=""rId\d+"")+"
    regEx.Global = True
    regEx.IgnoreCase = True

    ' Remplacer toutes les occurrences répétées par une seule
    lines = regEx.Replace(lines, "$1")
    GetavailableXmlCode = lines
    'Debug.Print lines
End Function
Sub testxx()
    Debug.Print GetavailableXmlCode("C:\Users\patricktoulon\Desktop\media\vmlDrawing1.vml")
End Sub

il va de soi que tout fichier et zip temporaire est supprimer
j'ai bloqué les lignes kill pour que vous puissiez aller voir les vml originals qui ont des doublons

reste à faire la même avec deux xmldoc maintenant

patricktoulon · 4 Février 2025

et voila l'hybride

VB:

Option Explicit
Sub Export_CommentairesPicturesVJURLAUPAT()
    'fonction et macros  patricktoulon
    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"
    Set UnZipeur = Nothing
    Kill sourceZip
    'fin de dézippage les VML compris


    '---------------------------Renommages des images avec les cture des vml-------------------------------'
    'Lecture  du vmlDrawing1.vml
    Dim xmlDoc, relsDoc, snodes, relNodes, relNode, imageName
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.LoadXML (GetavailableXmlCode(drawing1VML))
    Set snodes = xmlDoc.getElementsByTagName("v:shape")
    If snodes.Length = 0 Then MsgBox "la lecture du vml n'a pas pu être exécuté" & vbCrLf & " les images ne seront pas renomées": Exit Sub

    ReDim t(snodes.Length, 1 To 4)
    Dim R, C
    For i = 0 To snodes.Length - 1
        If snodes(i).getElementsByTagName("v:fill").Length > 0 Then
            t(i, 1) = snodes(i).getElementsByTagName("v:fill")(0).getAttribute("o:relid")
            R = CLng(snodes(i).getElementsByTagName("x:Row")(0).Text) + 1
            C = CLng(snodes(i).getElementsByTagName("x:Column")(0).Text) + 1
            t(i, 2) = Trim(ThisWorkbook.Sheets("INVENDUS").Cells(R, C).Value)
        Else
            MsgBox "la lecture du vml n'a pas pu être exécuté" & vbCrLf & " les images ne seront pas renomées": Exit Sub
        End If

    Next

    ' Charger le fichier RELS
    Set relsDoc = CreateObject("MSXML2.DOMDocument")
    relsDoc.async = False
    If Not relsDoc.Load(drawing1VMLREL) Then
        MsgBox "Erreur lors du chargement du fichier RELS: " & relsDoc.ParseError.Reason, vbCritical
        Exit Sub
    End If
    Set relNodes = relsDoc.getElementsByTagName("Relationship")
    If relNodes.Length = 0 Then MsgBox "la lecture du vmlRels n'a pas pu être exécuté" & vbCrLf & " les images ne seront pas renomées": Exit Sub
    ' Trouver le nom de l'image correspondant à ce rId dans le fichier RELS
    For i = LBound(t) To UBound(t)
        For Each relNode In relNodes
            imageName = ""
            If relNode.getAttribute("Id") = t(i, 1) Then
                imageName = Replace(relNode.getAttribute("Target"), "../media/", "")
                If Dir(DestFolderimage & "\" & imageName) <> "" Then
                    Dim Ext As String
                    Ext = Split(imageName, ".")(1)
                    Name DestFolderimage & "\" & imageName As DestFolderimage & "\" & t(i, 2) & "." & Ext
                End If
            End If
        Next relNode
    Next
    ' Libération des objets
       Set xmlDoc = Nothing
    Set relsDoc = Nothing
    MsgBox "Renommage terminé !", vbInformation
End Sub

Function GetavailableXmlCode(vml)
    'issue de la fonction de @laurent950
    Dim x&, lines$, regEx
    x = FreeFile: Open vml For Input As #x: lines = Input$(LOF(x), #x): Close #x
    Set regEx = CreateObject("VBScript.RegExp")

    ' Configurer la regex
    ' Cette expression recherche une première occurrence de o:relid="rIdX" suivie d'une ou plusieurs autres occurrences
    ' et remplace tout par la première occurrence.
    regEx.Pattern = "(o:relid=""rId\d+"")(\s+o:relid=""rId\d+"")+"
    regEx.Global = True
    regEx.IgnoreCase = True

    ' Remplacer toutes les occurrences répétées par une seule
    lines = regEx.Replace(lines, "$1")
    GetavailableXmlCode = lines
    'Debug.Print lines
End Function
Sub testyyy()
    Debug.Print GetavailableXmlCode("C:\Users\patricktoulon\Desktop\media\vmlDrawing1.vml")
End Sub

patricktoulon · 5 Février 2025

Bonjour @laurent950 , @jurassic pork , @fanch55 , @jeff1494
un petit kado'
la voici maintenant dans son propre dialog V1

avec aperçu instantané de l'image

c'est kool non ?

fanch55 · 5 Février 2025

patricktoulon à dit:
Bonjour @laurent950 , @jurassic pork , @fanch55 , @jeff1494
un petit kado'
la voici maintenant dans son propre dialog V1
avec aperçu instantané de l'image
c'est kool non ?

C'est plus que pas mal, mais ton code semble avoir du mal avec les fichiers autres que JPG.
Je te joins le classeur avec les 4 images supplémentaires .

patricktoulon · 5 Février 2025

Bonjour @fanch55
c'est normal le loadpicture ne fonctionne pas avec le png il faut mettre ma fonction loadPngPicture du creatorRibbonX imagemso

adapter a ce contexte
voila maintenant tu devrais pouvoir les voir

je viens de tester avec un png ca marche

patricktoulon · 5 Février 2025

il semblerait qu'il y est des soucis avec ta couronne même avec loadpicture et pourtant le wmf fonctionne très bien avec loadpicture en temps normal
j'ai essayé de l'ouvrir directement avec paint de l'archive ce qui fonctionne normalement et là j'ai la même erreur j'en conclu que ta couronne a un soucis

fanch55 · 5 Février 2025

patricktoulon à dit:
il semblerait qu'il y est des soucis avec ta couronne même avec loadpicture et pourtant le wmf fonctionne très bien avec loadpicture en temps normal
j'ai essayé de l'ouvrir directement avec paint de l'archive ce qui fonctionne normalement et là j'ai la même erreur j'en conclu que ta couronne a un soucis

? pas de problème chez moi :

Une dernière remarque, les extension Gif et Bmp sont remplacés par Png ?

XL 2021 Extraction images depuis commentaire de cellule vers dossier.

jeff1494

XLDnaute Occasionnel

Pièces jointes

laurent950

fanch55

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

jurassic pork

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

fanch55

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

Discussions similaires

XL 2021 Extraction images depuis commentaire de cellule vers dossier.

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency