XL 2021 Extraction images depuis commentaire de cellule vers dossier.

Sub ExtraireImagesDepuisClasseurOuvert()
    ' Déclaration des variables utilisées dans le code
    Dim ws As Worksheet               ' Déclare la variable pour la 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 à parcourir
    Dim lastRow As Long               ' Dernière ligne de la feuille (trouve la dernière ligne utilisée de 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         ' Chemin du dossier temporaire où le fichier ZIP sera extrait
    Dim DossierMedia As String        ' Chemin vers le sous-dossier "xl\media" où les images sont extraites
    Dim fso As Object                 ' Objet FileSystemObject utilisé pour la manipulation de fichiers/dossiers
    Dim sh As Object                  ' Objet Shell.Application pour interagir avec les fichiers ZIP
    Dim NSdest As Object, NSzip As Object ' Dossiers d'extraction (destination et source ZIP)
    Dim t As Single                   ' Variable pour calculer le temps écoulé (utilisé pour l'attente)
    Dim cheminImage As String         ' Variable non utilisée dans le code actuel (peut être supprimée)
    Dim NouveauNom As String          ' Nouveau nom pour renommer les images en fonction du commentaire de chaque cellule
    Dim i As Integer                  ' Compteur pour créer des noms uniques pour les images
    Dim fichierImage As String        ' Chemin complet du fichier image à traiter
    Dim image As Object               ' Représente un fichier image extrait dans le dossier "xl\media"
 
    ' Récupérer le chemin du classeur ouvert
    CheminClasseur = ThisWorkbook.FullName ' Chemin complet du fichier Excel actuellement ouvert
    CheminZip = ThisWorkbook.Path & "\TempClasseur.zip" ' Définir le chemin du fichier ZIP à créer
    DossierTemp = ThisWorkbook.Path & "\ExtractionTemp\" ' Définir le chemin du dossier temporaire d'extraction
    DossierMedia = DossierTemp & "xl\media\" ' Chemin vers le dossier où les images seront extraites
 
    ' Créer un objet FileSystemObject pour manipuler les fichiers/dossiers
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    ' Supprimer le dossier temporaire existant s'il existe
    On Error Resume Next ' Ignore les erreurs pour ne pas stopper le code en cas de dossier manquant
    If fso.FolderExists(DossierTemp) Then fso.DeleteFolder DossierTemp, True ' Supprimer le dossier et son contenu
    On Error GoTo 0 ' Restaurer la gestion des erreurs par défaut
 
    ' Créer un nouveau dossier temporaire
    fso.CreateFolder DossierTemp
 
    ' Copier le classeur ouvert dans un fichier ZIP
    fso.CopyFile CheminClasseur, CheminZip, True ' Crée une copie du classeur sous forme de fichier ZIP
 
    ' Attendre que le fichier ZIP soit effectivement créé
    t = Timer ' Récupère l'heure de départ
    Do While Not fso.FileExists(CheminZip) ' Boucle tant que le fichier ZIP n'est pas créé
        DoEvents ' Permet à d'autres événements de se produire (pour ne pas bloquer Excel)
        If Timer - t > 5 Then ' Si l'attente dépasse 5 secondes
            MsgBox "Le fichier ZIP n'a pas été créé dans les 5 secondes.", vbCritical
            Exit Sub ' Quitte la macro si le fichier ZIP n'est pas créé dans le délai
        End If
    Loop
 
    ' Créer un objet Shell.Application pour extraire le contenu du ZIP
    Set sh = CreateObject("Shell.Application")
    Set NSdest = sh.Namespace(fso.GetAbsolutePathName(DossierTemp)) ' Dossier de destination pour l'extraction
    Set NSzip = sh.Namespace(fso.GetAbsolutePathName(CheminZip)) ' Fichier ZIP à extraire
 
    ' Extraire le contenu du fichier ZIP dans le dossier temporaire
    NSdest.CopyHere NSzip.Items, 16 ' Le "16" est un flag qui permet l'extraction en mode silencieux
 
    ' Attendre l'apparition du dossier "xl\media" après extraction
    t = Timer ' Récupère l'heure de départ
    Do While Not fso.FolderExists(DossierMedia) ' Boucle tant que le dossier "xl\media" n'existe pas
        DoEvents
        If Timer - t > 10 Then Exit Do ' Quitter après 10 secondes si le dossier n'apparaît pas
    Loop
 
    ' Vérifier si les images ont bien été extraites dans le dossier "xl\media"
    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
    End If
 
    ' Définir la feuille "INVENDUS" pour travailler avec les données
    Set ws = ThisWorkbook.Worksheets("INVENDUS")
    lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row ' Trouver la dernière ligne utilisée dans la colonne B
    Set Plg = ws.Range("B2:B" & lastRow) ' Définir la plage à parcourir (de B2 à la dernière ligne)

    ' Examiner les fichiers extraits et associer chaque image avec le commentaire de la cellule
    i = 0 ' Initialiser le compteur pour les images
    For Each Cell In Plg ' Parcourir chaque cellule de la plage
        If Not Cell.Comment Is Nothing Then ' Si la cellule contient un commentaire
            ' Extraire le texte du commentaire pour créer un nom d'image unique
            NouveauNom = Cell.Value2
 
            ' Vérifier si le dossier média existe
            If fso.FolderExists(DossierMedia) Then
                ' Parcourir les fichiers dans le dossier média
                For Each image In fso.GetFolder(DossierMedia).Files
                    If InStr(1, image.Name, "image") > 0 Then ' Vérifier que le fichier est une image
                        i = i + 1
                        fichierImage = DossierMedia & "image" & i & ".jpeg" ' Créer le nom complet du fichier image
                        ' Si le fichier image existe, renommer l'image
                        If fso.FileExists(fichierImage) Then
                            fso.MoveFile fichierImage, DossierMedia & NouveauNom & ".jpg" ' Renommer l'image avec le texte du commentaire
                            Exit For ' Quitter la boucle dès qu'une image est renommée
                        End If
                    End If
                Next image
            End If
        End If
    Next Cell

    ' Libération des objets pour éviter les fuites de mémoire
    Set fso = Nothing
    Set sh = Nothing
    Set NSdest = Nothing
    Set NSzip = Nothing
    Set ws = Nothing
End Sub

Sub test()
 Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.async = False
    xmldoc.Load "C:\Users\patricktoulon\Desktop\media\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:shape")
  MsgBox xmldoc.XML
End Sub

 <v:fill o:relid="rId1" o:relid="rId1" o:relid="rId1" o:relid="rId1" o:title="OBJ006"

    drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").Items.Item("vmlDrawing1.vml").Path
    UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VML)
    drawing1VML = DestFolderimage & "\vmlDrawing1.vml"

    '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
    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ée"
End Sub

Sub ChargerDicts(vmlFile, vmlrelFile, DictShp, DictFile)
    Dim fileName$, objName, relId$, shapeId$, XmlNamespaces$
    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
    xmlDoc.Load vmlFile
    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
    xmlDoc.Load vmlrelFile
    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