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...

patricktoulon · 30 Janvier 2025

et avec ma petite shellandwait avec macro 4 sur les api?

VB:

'fonction shell améliorée avec gestion d'attente de fin de processus
'pratique quand on lance un bath ou cmd
Function ShellAndwaitingEndProcess(ByVal CheminComplet As String) As Long
    Dim ProcessHandle As Long
    Dim ProcessId As Long
    ProcessId = Shell(CheminComplet, vbHide)
    ProcessHandle = ExecuteExcel4Macro("CALL(""Kernel32"",""OpenProcess"",""JJJJ"",""" & 2031616 & """,""" & 0 & """,""" & ProcessId & """)")
    ShellAndwaitingEndProcess = ExecuteExcel4Macro("CALL(""Kernel32"",""WaitForSingleObject"",""JJJJJ"",""" & ProcessHandle & """,""" & &HF0000 & """)")
End Function

fanch55 · 30 Janvier 2025

J'ai attendu comme cela :

VB:

                Pid = Shell(Cmd, vbHide)
                Do While _
                    GetObject("winmgmts:root\cimv2"). _
                    execQuery("select * from Win32_process where processid=" & Pid).Count > 0
                    DoEvents
                Loop

Les 25 images prennent 2 secondes de plus qu' avec le WScript.Shell qui lui intègre déjà un wait .

patricktoulon · 30 Janvier 2025

ben c'est pas grave compile tout ca dans une fonction
ça peut toujours servir pour ceux qui ne veulent pas les api ou installer le com de jurassic pork
je récapitule
méthode possible:
méthode par graphique
com de jurassic pork(installation requise)
le zip and unzip
le html
le clipboard (user32 et kernel)écriture en binnaire du fichier
powershell en commande par le wscript.shell

bref là le jeff il en a des solutions non?

laurent950 · 30 Janvier 2025

Bonsoir @jeff1494

J'ai revu ma copie et trouvé une astuce. Pour l'extraction de 50 images, c'est ultra rapide et j'ai fait simple selon mon poste #2
Poste #2 : https://excel-downloads.com/threads...e-cellule-vers-dossier.20086089/post-20676844

Méthode par graphique :
Cette méthode consiste à copier l'image contenue dans le commentaire d'une cellule et à la coller dans un graphique temporaire. L'image est ensuite exportée vers un dossier spécifié. Après l'exportation, l'image est supprimée du graphique, mais sans affecter le graphique lui-même.

Une astuce clé est de rendre le graphique actif avant de commencer la boucle. Cela évite le problème du "carré blanc" lors de l'exportation, où l'image ne se colle pas correctement si le graphique n'est pas actif. Cette approche permet de garantir la compatibilité avec toutes les versions d'Excel depuis 2016.

VB:

Option Explicit

Sub Export_Photos()
  Dim wks As Worksheet
  Dim Plg As Range
  Dim cell As Range
  Dim lastRow As Long
  Dim ImgCounter As Integer
  Dim CharObj As ChartObject
  Dim TempChart As Chart
  Dim shp As Shape
  Dim imgName As String
  Dim FolderPath As String
' Créer le dossier s'il n'existe pas.
    If Dir(ThisWorkbook.Path & "\JPG_INV", vbDirectory) = "" Then
        MkDir ThisWorkbook.Path & "\JPG_INV"
    End If
' Mémoriser la feuille active.
    Set wks = ActiveSheet
' Cellule 2 à la dernière cellule non vide de la colonne B.
    lastRow = wks.Cells(wks.Rows.Count, 2).End(xlUp).Row
' Plage de recherche des images dans les commentaires.
    Set Plg = wks.Range("B2:B" & lastRow)
' Initialiser le compteur d'images.
    ImgCounter = 0
' Astuce :
' * Ajouter un graphique temporaire (en amont de la boucle de recherche)
    Set CharObj = wks.ChartObjects.Add(Left:=100, Width:=100, Top:=100, Height:=100)
    Set TempChart = CharObj.Chart ' Ici mise en mémoire de l'objet Chart
        TempChart.Parent.Activate ' Ici l'astuce (rendre cette objet actif "Contournement carré Blanc)
' Mémoriser le chemin d'enregistrement des extractions des images vers le dossier final.
    FolderPath = ThisWorkbook.Path & "\JPG_INV\"
' Parcourt toutes les formes de la feuille active.
    For Each cell In Plg
    ' Vérifie si la cellule contient un commentaire.
        If Not cell.Comment Is Nothing Then
        ' Stocker l'objet Shape associé à un commentaire
            Set shp = cell.Comment.Shape
            ' Vérifie si le type de remplissage de l'objet graphique (Shape) est une image.
            ' La valeur 6 correspond à msoFillPicture, qui indique un remplissage par une image.
                If shp.Fill.Type = 6 Then
                ' Affiche le commentaire.
                    shp.Visible = msoTrue
                ' Copie l'image du commentaire.
                    shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                ' Colle l'image du commentaire dans l'objet graphique.
                    TempChart.Parent.Height = shp.Height ' .... Correctif de 100*100 (Astuce @patricktoulon)
                    TempChart.Parent.Width = shp.Width ' ....... Correctif de 100*100 (Astuce @patricktoulon)
                    TempChart.Paste
                ' Créer le chemin et le nom de l'image.
                    imgName = FolderPath & cell.Value & ".png"
                ' Exporter l'image dans le dossier "précédemment créé".
                    TempChart.Export FileName:=imgName, FilterName:="PNG"
                ' Optionel comptes les images exporté
                    ImgCounter = ImgCounter + 1
                ' Supprime l'objet image a l'intérieur de l'objet Chart sans le supprimé.
                    TempChart.Parent.Chart.Shapes(1).Delete
                End If
        End If
    Next cell
'   Supprime l'objet Chart en fin de programme
    CharObj.Delete
'
    ' Message de confirmation
        If ImgCounter > 1 Then
            'MsgBox "Exportation terminée. " & (ImgCounter - 1) & " images exportées vers " & imgPathChoix, vbInformation
            MsgBox ImgCounter - 1 & " images ont été exportées dans " & FolderPath, vbInformation
        Else
            MsgBox "Aucune image n'a été exportée.", vbExclamation
        End If
End Sub

patricktoulon · 31 Janvier 2025

re
c'est pas Mal Laurent tu a rendu rapide une méthode qui ne l'ai pas
par contre le message me dit que 4 images ont été copiées mais il y en a cinq

mais en même temps tes images font 100 x100
en remettant les images a leur taille ça ralenti quand même

VB:

Option Explicit

Sub Export_Photos6()
  Dim wks As Worksheet
  Dim Plg As Range
  Dim cell As Range
  Dim lastRow As Long
  Dim ImgCounter As Integer
  Dim CharObj As ChartObject
  Dim TempChart As Chart
  Dim shp As Shape
  Dim imgName As String
  Dim FolderPath As String
' Créer le dossier s'il n'existe pas.
    If Dir(ThisWorkbook.Path & "\JPG_INV", vbDirectory) = "" Then
        MkDir ThisWorkbook.Path & "\JPG_INV"
    End If
' Mémoriser la feuille active.
    Set wks = ActiveSheet
' Cellule 2 à la dernière cellule non vide de la colonne B.
    lastRow = wks.Cells(wks.Rows.Count, 2).End(xlUp).Row
' Plage de recherche des images dans les commentaires.
    Set Plg = wks.Range("B2:B" & lastRow)
' Initialiser le compteur d'images.
    ImgCounter = 0
' Astuce :
' * Ajouter un graphique temporaire (en amont de la boucle de recherche)
    Set CharObj = wks.ChartObjects.Add(Left:=100, Width:=100, Top:=100, Height:=100)
    Set TempChart = CharObj.Chart ' Ici mise en mémoire de l'objet Chart
        TempChart.Parent.Activate ' Ici l'astuce (rendre cette objet actif "Contournement carré Blanc)
' Mémoriser le chemin d'enregistrement des extractions des images vers le dossier final.
    FolderPath = ThisWorkbook.Path & "\JPG_INV\"
' Parcourt toutes les formes de la feuille active.
    For Each cell In Plg
    ' Vérifie si la cellule contient un commentaire.
        If Not cell.Comment Is Nothing Then
        ' Stocker l'objet Shape associé à un commentaire
            Set shp = cell.Comment.Shape
            CharObj.Height = shp.Height
            CharObj.Width = shp.Width
            ' Vérifie si le type de remplissage de l'objet graphique (Shape) est une image.
            ' La valeur 6 correspond à msoFillPicture, qui indique un remplissage par une image.
                If shp.Fill.Type = 6 Then
                ' Affiche le commentaire.
                    shp.Visible = msoTrue
                ' Copie l'image du commentaire.
                    shp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                ' Colle l'image du commentaire dans l'objet graphique.
                    TempChart.Paste
                ' Créer le chemin et le nom de l'image.
                    imgName = FolderPath & cell.Value & ".png"
                ' Exporter l'image dans le dossier "précédemment créé".
                    TempChart.Export FileName:=imgName, FilterName:="PNG"
                ' Optionel comptes les images exporté
                    ImgCounter = ImgCounter + 1
                ' Supprime l'objet image a l'intérieur de l'objet Chart sans le supprimé.
                    TempChart.Parent.Chart.Shapes(1).Delete
                End If
        End If
    Next cell
'   Supprime l'objet Chart en fin de programme
    CharObj.Delete
'
    ' Message de confirmation
        If ImgCounter > 1 Then
            'MsgBox "Exportation terminée. " & (ImgCounter - 1) & " images exportées vers " & imgPathChoix, vbInformation
            MsgBox ImgCounter - 1 & " images ont été exportées dans " & FolderPath, vbInformation
        Else
            MsgBox "Aucune image n'a été exportée.", vbExclamation
        End If
End Sub

Attention le poids des images est encore excessif

jurassic pork · 31 Janvier 2025

patricktoulon à dit:
je récapitule
méthode possible:
méthode par graphique
com de jurassic pork(installation requise)
le zip and unzip
le html
le clipboard (user32 et kernel)écriture en binnaire du fichier
powershell en commande par le wscript.shell

Hello,
tu as oublié ma méthode du post #43 qui ne fait qu'un Unzip et qui prend les fichiers jpeg originaux et qui n'utilise pas le presse-papiers.
J'ai revu ma copie pour être sûr de ne copier que les images qui se trouvent dans les commentaires des objets.
Voici le nouveau principe :
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 l'id de la Shape (shapId) et son id de relation (relId)
Le fichier vmlDrawing1.vml.rels qui donne la correspondance entre le relId de la Shape et le nom d'image incluse dans le classeur.
5 - Pour faire la corrélation entre les deux fichiers on utilisera deux dictionnaires.
6 - On balaie les objets dans le tableau du classeur et quand il y a un commentaire avec une image , on copie l'image dans le répertoire
de destination avec le nom de l'objet.
Voici le code :

VB:

Sub Export_PhotosDirect()
    Dim FSO As Object, SourceFile$, DestFile$, DestImages$, Fname$, ZipPath$
    Dim DictShp As Object, DictFile As Object, Ccom As Object, Cel, res
'    Dim Pwsh As Object
'    Set Pwsh = CreateObject("XlDnaLibJP.ClPowerShell")
'    Dim bm As New cBenchmark
    Set DictShp = CreateObject("Scripting.Dictionary")
    Set DictFile = CreateObject("Scripting.Dictionary")

    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"
'    bm.Start
    Call FSO.CopyFile(SourceFile, DestFile, True) 'OverWrite
'    bm.TrackByName "CopyFile"
    'UnzipAFile DestFile, ZipPath
    CreateObject("WScript.Shell").Run "powershell Expand-Archive " & _
                                  DestFile & " -DestinationPath " & ZipPath, 7, True
    'res = Pwsh.ExecuteCmd("Expand-Archive " & DestFile & " -DestinationPath " & ZipPath)
    'Debug.Print res
'    bm.TrackByName "UnZip"
    ChargerDicos ZipPath, DictShp, DictFile
'    bm.TrackByName "ChargerDicos"
    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)))
           FSO.CopyFile ZipPath & "\xl\media\" & Fname, _
               DestImages & Cel.offset(, -1) & ".jpg", True
         End Select
    Next
'    bm.TrackByName "Copie Images"
    FSO.DeleteFolder ZipPath
    Kill DestFile
    Set FSO = Nothing: Set DictShp = Nothing: Set DictFile = Nothing
End Sub

Sub ChargerDicos(ZipPath, 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 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: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 ZipPath & "\xl\Drawings\_rels\vmlDrawing1.vml.rels"
    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

J'ai mis en commentaire les mesures de benchmark et l'utilisation de ma classe ClPowershell qui accélère l'exécution du Powershell.

Dans le répertoire destination j'ai bien toutes les images de tous les objets avec la taille originale des jpeg et même leur date d'insertion.

Voici le benchmark pour 6 objets :

CopyFile	1,58ms
UnZip	610ms
ChargerDicos	3,14ms
Copie Images	4,07ms
TOTAL	619ms

Ceci est le benchmark en utilisant ClPowerShell, en utilisant WScript.Shell il faut compter 1 seconde de plus.
Comme on peut le constater c'est le Unzip qui prend le plus de temps et cela sera plus important avec le classeur qui contient toutes les images (d'ailleurs il fait quelle taille ce classeur ? ).
Ami calmant, J.P

patricktoulon · 31 Janvier 2025

re
Bonjour @jurassic pork je n'avais pas oublié
je n'ai pas juger utile de decrire les deux versions

pour ta nouvelle version:
tu oublie un détail crucial
tu fait un "Call FSO.CopyFile(SourceFile, DestFile, True) 'OverWrite"

et oui mais ce qui a été fait depuis et pendant l'ouverture ne sera pas pris en compte
il te faut remplacer cela par un savecopyAs

patricktoulon · 31 Janvier 2025

re
@jurassic pork

et c'est normal a mon avis powershell n'est pas syncrone

patricktoulon · 31 Janvier 2025

@jurassic pork je te propose de changer ta partie zip pour celle ci
tu te retrouve avec le dossier media a la racine du classeur et tu a tes images et tes deux fichiers ".vml"

VB:

Sub Export_PhotosVPat()
    Dim oApp As Object
    Dim sourceZip$
    Dim folderZipimage$
    Dim DestFolderimage$
    Dim drawing1VML$
    Dim drawing1VMLREL$

    '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
        Kill DestFolderimage & "\*.*"
        RmDir DestFolderimage
    End If
   
    '-------------------------------------------------------
    '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)

    'chemin du drawing1.vml
    drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").items.Item("vmlDrawing1.vml").Path
    'extraction du "vmlDrawing1.vml"
    UnZipeur.Namespace(DestFolderimage & "\").copyhere (drawing1VML)
    drawing1VML = DestFolderimage & "\vmlDrawing1.vml"

    'chemin du drawing1.vml
    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"
    Set UnZipeur = Nothing
    Kill sourceZip
    'fin de dézippage les VML compris
    '----------------------------------------------------------

End Sub

reste plus à renommer
la différence
le zip est un map du xlsm a l'intant T
on passe plus par powershell
et l'object est retenu tant qu'il n'a pas fini donc pour le reste ce sera synchrone
qu'en dit tu?

patricktoulon · 31 Janvier 2025

@jurassic pork
bon ben finement j'ai trouvé le code pour l'extraction en masse
pas besoin des deux vml le .rels suffit

1°on sauve le classeur en copie ".zip"
2°on ouvre une instance de Shell.Application
3°on détermine le chemin complet zip du dossier media et on l'extrait a la racine du classeur
4°on détermine et extrait le fichier vml.rels qui ne contient que les relationchips des commentaire(vérifié) par forcement dans l'ordre)
5°on ferme le shell
6° on lit le rels en xml
---a) on récupère l'index dans le id en replaçant "rId" par rien
---b) on récupère le "Target"en replaçant le ".." et complétant avec la racine et la valeur de la colonne désignation par l'index de cellule
---c) on renomme les fichier avec la fonction name
7°message de fin et suppression du fichier rels
terminé c'est une extraction en masse puisque je récupère le dossier media complet
8° on pourrait ajouter une boucle dir de netoyage des fichier image qui n'on rien a voir avec les commentaires si il faut

VB:

Sub Export_PhotosVPat()
    Dim oApp As Object, sourceZip$, folderZipimage$, DestFolderimage$, drawing1VML$, drawing1VMLREL$, I&

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

    '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"
    Set UnZipeur = Nothing
    Kill sourceZip
    'fin de dézippage les VML compris
    '----------------------------------------------------------
    'Renommer les 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 drawing1VMLREL
  MsgBox "Extraction des images de commentaires terminées"
End Sub

voila une belle extraction en masse

jeff1494 · 1 Février 2025

Bonjour à toutes et tous;
Un grand merci à tous ceux qui contribuent à répondre à mon message.
Alors au début je pensais que mon problème pourrait ne pas intéresser beaucoup de monde.
Mais quand je vois le résultat, j'en reste bouche bée.

@patricktoulon quand tu dis "si avec ça il n'a pas de solution qu'il le jette son fichier 🤣🤣🤣" au post #46, j'y ai pensé très fortement, mais le sang breton qui coule dans mes veines et qui me rend si têtu, parfois, m'a fait continuer. Et au final j'en suis content.

Donc à partir d'une simple demande quand je vous voit sortir autant de solutions, et de comparaisons pointues en terme de temps d'exécution, et autres considérations, je me dis que je ne suis pas prêt d'arriver à réaliser le millième de ce que vous écrivez comme code. Il me reste encore beaucoup de chemin à faire, mais en marchant à mon rythme peut-être arriverai-je à quelque chose, qui sait.

Maintenant je vais essayer tous vos codes, non pas pour dire qui est le meilleur, j'en suis bien incapable, mais pour utiliser celui que je comprends et que je me sens le plus à même d'expliquer. Cela signifiera pour moi que je l'ai compris et fait mien.

Dans tous les cas je ne vous remercierai jamais assez pour votre aide qui m'aide à progresser, à ma modeste vitesse.
Bon week-end à toutes et tous.

patricktoulon · 1 Février 2025

Bonjour jeff
pour la meilleure solution qui concilie vitesse / format / et poids c'est ma derniere
pas parce que c'est la mienne mais
par ce que
elle est relativement rapide puisque je fait une extraction de masse en recuperant le dossier dans le zip du fichier elle respecte le format puisque je prends ce qu'il y a
et le poids c'est le poids original des image

celle de jurassic pork est bien aussi sauf qu'il se base sur une copy du fichier avant ouverture puisqu'il utilise filecopy
bon il m'a un peu perdu dans le décantage des xml pour le renommage
alors que c'est simple ledrawing1.vml.rels ne contient que les commentaires

en suite la plus rapide de toute est sans conteste (encore une fois la mienne avec ma fonction png api)
sauf que ca exporte en png (depuis j'ai ajouté la conversion via WIA 20ms supplémentaires)

mais je ne l'ai pas re diffusé car je pense sincèrement que le unzip reste la meilleure solution équilibrant vitesse/format/poids/(compatibilite/rétrocompatibilité) et oui il faut y penser
demander a utilisateur d'installer ou de modifier son registre est une responsabilité
c'est pas pour dénigrer le travail de @jurassic pork bien au contraire son truc marche très bien chez moi en 32

par contre et là ça s'adresse à toi
j'ai regardé un peu les codes des modules
par exemple moi ,en tant qu'utilisateur averti, ton fichier part directement tu sais ou

pourquoi
1° et bien par ce que tu fait du repurpose de module sans demander l'avis de utilisateur
ce qui sera pas possible si certaines option ne sont pas activées et si le system est protégé comme dans les entreprise ou certaines librairies seront bloquées et donc ton fichier ne pourra fonctionner

2° tu fait de l'insertion et écriture de module dynamique ( là tu vois j'ai tout mes radars déclenchés)

3° c'est assez désordonné quand même

4° et bien d'autre choses encore

je suis sur qu'a plusieurs d'entre nous on pourrait te proposer des méthodes plus orthodoxes et plus respectueuses des règles de base dans le développement d'un applicatif

une chose est sure et certaine à 100% si tu ne change pas de politique de méthode ton applicatif est voué a être jeté par les utilisateur
alors je sais tu veux faire ceci ou cela
mais je le redis il y a des méthodes pour ça
mais un truc aussi invasif tel qu'il est là pour moi c'est mort

pardonne moi ma franchise mais je part du principe que dire les choses sans détour évite les malentendus et quiproquos
et permet d'avancer dans la bonne direction

en toute bienveillance
Patrick 😉

jeff1494 · 1 Février 2025

@patricktoulon ;
Je te remercie pour ta franchise et tes critiques que je trouve très constructives, donc je les prend avec tout le respect que je dois à quelqu'un qui prend de son temps pour aider les autres et que je sais être un expert.

Peu-être devrais-je t'expliquer à quoi et à qui va servir cet applicatif.
Je l'ai créé car je vend occasionnellement des anciennes choses dans un vide-grenier permanent.
Seul mon frère et moi seront ceux qui vont utiliser cela.
Donc pas d'idée pour moi de le redistribuer, même si à un moment j'y avais pensé.
J'ai juste pris le parti de faire quelque chose d'automatisé, de manière à apprendre à faire des choses que je ne maitrise pas encore.

Je suis bien conscient que si cet appli devait être distribuée, en effet je pense qu'elle finirait à la poubelle très très vite.

En fait j'essaie toujours de trouver un intérêt personnel pour me lancer dans un développement.
J'admets manquer cruellement de méthodologie, et de bonne pratiques, mais je ne désespère pas d'apprendre à aborder ces choses d'une manière plus rigoureuse.

Je prends donc tous les conseils, et remarques avec un œil très modeste, et les accepte en toute humilité sachant bien que j'ai encore beaucoup de choses à apprendre.

Je vais essayer de documenter ce que je veux faire et comment je vois les choses. Cela devrait m'éclairer sur le fait que je ne suis pas assez rigoureux et que j'ai tendance à essayer de coder avant d'avoir réfléchi. Et probablement m'éviter de faire des bêtises évitables juste en y réfléchissant avant plutôt qu'après.

Dans tous les cas je te remercie pour ta franchise et ta bienveillance, et surtout ton aide.
Sur ce bon week-end à toi.

jurassic pork · 1 Février 2025

patricktoulon à dit:
celle de jurassic pork est bien aussi sauf qu'il se base sur une copy du fichier avant ouverture puisqu'il utilise filecopy
bon il m'a un peu perdu dans le décantage des xml pour le renommage
alors que c'est simple ledrawing1.vml.rels ne contient que les commentaires
😉

Hello patricktoulon,
excellente ta simplification du dézipage. Ce n'est pas pour t'embrouiller que j'avais rajouté une couche dans les xml . Tu as de la chance , dans l'exemple les images sont dans le même ordre que les objets, mais si on mélange un peu , cela n'est plus exact. De plus il peut y avoir plusieurs objets qui pointent vers la même image et là tu ne vas sortir qu'une image au lieu de deux. En pièce jointe un classeur avec ton code et avec les objets mélangés et deux objets qui pointent vers la même image (cas où l'on possède plusieurs fois le même objet). Tu verras que ce qu'il y a dans le répertoire de destination n'est pas bon :

Si tu testes avec mon code (avec une modif pour avoir la description au lieu du nom d'objet) tu verras que cela semble correct :

Ami calmant, J.P

patricktoulon · 1 Février 2025

bien vu jp
je sais pas comment tu a fait pour mettre le boxon
après pour les image en doublons ca se discute (avoir 2 images en doublons de même nom)
apres dans le fichier que tu viens de renvoyer les rId ne sont plus cohérents entre les deux xml alors difficile de faire le relation avec les index de cells autrement dit il faut trouver un autre moyen de faire la relation avec les cells

XL 2021 Extraction images depuis commentaire de cellule vers dossier.

jeff1494

XLDnaute Occasionnel

Pièces jointes

laurent950

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

jurassic pork

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

jeff1494

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

jeff1494

XLDnaute Occasionnel

jurassic pork

XLDnaute Accro

Pièces jointes

patricktoulon

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 Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency