XL 2016 Lister fichiers avec Exifs et propriétés (suivant son choix) - code à modifier

re4

XLDnaute Occasionnel
Edit 19/04/2021 : Les solutions sont aux posts #28 et #44 un grand merci à Dudu2

Bonjour à tous,
Je reviens avec une autre idée avec le code ci-dessous que j'ai légèrement modifé avec quelques annotations de débutant (que je suis ,-)
Cette macro fonctionne bien et extrait seulement les exifs que l'on désire avec quelque prérequis.

Je ne sais pas faire, vous est-il possible de m'aider et de la modifié pour :
1- Aller chercher le répertoire par l'ouverture d'une boite (explorer ?), à la place de : Set objFolder = objShell.Namespace("C:\Users\PC\Pictures\Test")
2- Lister à partir du dossier racine tous les fichiers de tous les sous répertoires.

Merci beaucoup

VB:
'original ?
    'https://www.excel-downloads.com/threads/macro-pour-extraire-l

    'Prérequis
    'créer une feuille ''Code'' avec en tête en ligne 1:
    'Colonne A les codes de toutes propriétés
    'Colonne B les noms de ces propriétés
    'Colonne C un X par exemple pour ne choisir que les plus utiles
    'Colonne D index par ordre de péférence (noms que l'on veut, puis tris de A-Z sur colonne D)
    'Colonne E les codes (colonne A) du tri de D

    ' Ne liste que le repertoire choisi (mais affiche les dossiers sous répertoire en nom)

    Sub LireExifTags5()
    Dim det_Headers(355)

    Sheets("Code").Select

    ' compte le nbre de cellule non vide de la colonne E de la feuille 'Code'
    LastRow = Cells(Rows.Count, 5).End(xlUp).Row

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace("C:\Users\PC\Pictures\Test")

    Workbooks(1).Sheets(1).Activate
        DernLigClear = Range("A" & Rows.Count).End(xlUp).Row

        Range("A2:OJ" & DernLigClear).ClearContents 'jusqu'a la colonne 400

    For i = 2 To LastRow
    c = i - 2
    k = Worksheets("Code").Cells(i, 5) 'Seulement les exifs que l'on désire

    det_Headers(c) = objFolder.GetDetailsOf(objFolder.Items, k)
    ActiveSheet.Cells(2, c + 1) = det_Headers(c) 'headers en ligne 2

    Workbooks(1).Sheets(1).Activate
    j = 3 ' pour datas en ligne 3

    For Each strFileName In objFolder.Items
    For m = 1 To LastRow
    Next

    Sheets(1).Cells(j, i - 1).Value = objFolder.GetDetailsOf(strFileName, k)

    j = j + 1

    Next
    Next

    'Columns("A:z").AutoFit
    ActiveSheet.UsedRange.EntireColumn.AutoFit
    End Sub
 
Dernière édition:
Solution
OK. Si le titre de la colonne E est "Ordre" la formule serait mieux avec =SI([@Ordre]>0;"Oui";"Non")
C'est une syntaxe propre aux tableaux structurés (le symbole @ représente la ligne courante).

Mais à partir du moment où c'est le chiffre qui déclenche l'affichage, on peut se passer de la colonne "Afficher".
Voici une version qui, selon ta préférence, utilise la colonne Ordre (de classement) dont la gestion requiert la ré-attribution des numéros et le tri du tableau (bouton dédié) en cas de modification de classement.
Pour le centrage vertical des lignes tu as une idée ?
Une instruction VBA.

Fichier mis à jour 21/04/2021 14h32

patricktoulon

XLDnaute Barbatruc
oui avec WIA

VB:
Sub creation_TAG_TITRE_copieImage()
    Dim Img As ImageFile
    Dim IP As ImageProcess
    Dim v As Vector
    Dim i As Integer
    
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.imageFile")
    
    'creation du gestionnaire de filtre
    Set IP = CreateObject("WIA.imageProcess")
    
    'création d'un vecteur
    '(Un vecteur permet de créer une collection pour des valeurs du même type.)
    Set v = CreateObject("WIA.Vector")
    
    'chargement de l'image
    Img.LoadFile "C:\fourmiz.JPG"
    
    'définit le filtre pour gérer l'EXIF
    IP.Filters.Add IP.FilterInfos("Exif").FilterID
    IP.Filters(1).Properties("ID") = 40091
        '40091  Titre
        '40092  Commentaire
        '40093  Auteur
        '40094  Mots clés 

        'spécifie le type de valeur pour le propriété du filtre:
        'constante VectorOfBytesImagePropertyType = 1101 (la valeur est un vecteur)
        IP.Filters(1).Properties("Type") = VectorOfBytesImagePropertyType
        'voir le fichier d'aide fourni avec la librairie WIA pour
        'obtenir la liste des constantes disponibles
    
    'stocke une chaine de caractères dans le vecteur
    v.SetFromString "Test de TAG 'TITRE' : utilisation de WIA v2.0"
    
    'applique au filtre le contenu du vecteur 
    IP.Filters(1).Properties("Value") = v
                
    'application du filtre dans l'image
    Set Img = IP.Apply(Img)
    
    'sauvegarde de l'image
    Img.SaveFile "C:\fourmiz_Test_EXIF.JPG"
End Sub
 
Dernière édition:

MJ13

XLDnaute Barbatruc
Re
Sur le même principe de Patrick, j'ai ce code que je me servais, il y a quelques années:

VB:
Public cell
Sub deb_Redim_Imgs()
'Stop
ActiveSheet.Pictures.Delete
derl = Cells(Rows.Count, 2).End(xlUp).Row
Columns("C:C").ColumnWidth = Cells(1, 10).Value / 5
'Rows("3:" & derl).RowHeight = Cells(1, 10)
If Cells(1, 10).Value > 400 Then Rows("3:" & derl).RowHeight = 409 Else Rows("3:" & derl).RowHeight = Cells(1, 10).Value
For Each cell In Range("C2:C" & Range("B" & Rows.Count).End(xlUp).Row)
If UCase(Right(cell, 3)) = "JPG" Then cell.Select: RedimensionnerImage
Next

ActiveSheet.Pictures.Select
Selection.Placement = xlMoveAndSize

MEF_B1_H1
Rows("1:1").RowHeight = 117.5

[A1].Select
[A2].Select
End Sub
Sub RedimensionnerImage()
'MichelXLD nécessite la wiaaut.dll (\Outils \Référence)
'Alt+F11 puis Alt+O puis r(voir dans les références si vous avez la Microsoft Windows Image Acquisition Librairy V2.0 )
On Error Resume Next
    Dim Img As WIA.ImageFile, IP As WIA.ImageProcess
    'For n = 100 To 1000 Step 100
'    Stop
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
    
    'Chargement de l'image dans le conteneur
    'Img.LoadFile "C:\Temp\Test.JPG"
'    Stop
    
    Img.LoadFile ActiveCell.Offset(0, -1).Value & "\" & cell
     'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = Sheets("Liste Fichiers").Range("J1")
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = Sheets("Liste Fichiers").Range("J1")
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
        'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    'Img.SaveFile "C:\Temp\TestThumbnail" & n & ".JPG"
Fichier = "c:\Img\" & Mid(cell, 1, Len(cell) - 4) & "thumb.jpg"
Img.SaveFile "c:\Img\" & Mid(cell, 1, Len(cell) - 4) & "thumb.jpg"
larg = Img.Width
haut = Img.Height
Set Shp = ActiveSheet.Shapes.AddPicture _
        (Fichier, msoTrue, msoCTrue, cell.Left + 2, cell.Top + 2, larg, haut)
        
        Kill "c:\Img\" & Mid(cell, 1, Len(cell) - 4) & "thumb.jpg"
        
    'Next
End Sub
 

Dudu2

XLDnaute Barbatruc
Pour moi la question est: dois-je développer l'affichage dynamique des miniatures ?
Perso je n'en ai pas besoin. Si quelqu'un y voit un intérêt je le fais sinon, je vais juste intégrer la conversion des Raw avec ImageMagick.
 

Dudu2

XLDnaute Barbatruc
Dans l'autre sujet... oui je l'ai vue.
Tu dis "ça va très vite" mais je ne comprends pas pourquoi ça irait plus vite en VBS et pas en natif DLL.
De plus quand tu fais .Run Scripts & " " & Source & " """ & Destination & """ ", ça n'attend pas la fin du script pour passer à l'instruction suivante. Alors à quel moment je récupère mes billes ?
 

patricktoulon

XLDnaute Barbatruc
quand tu fait une serie tu fait tout d'un coup tu debloque la ligne do loop en vert et apres ca tu a acces a toutes les images converties

pour quoi ca va plus vite
ben tu t'es donné la réponse tout ,seul en fait elle passe a la suivante avant d'avoir fini la précédente
 

Dudu2

XLDnaute Barbatruc
OK, je vois ce que tu veux dire. Maintenant faut voir si tous ces Scripts lancés en parallèle se terminent vraiment beaucoup plus rapidement que des conversions en série. La CPU n'est pas infinie. Faudrait essayer pour voir le gain.
D'ailleurs la boucle en DoEvents consomme pas mal. Faudrait essayer avec des Application.OnTime de 1 seconde ou des Sleep.
 

patricktoulon

XLDnaute Barbatruc
hoh ben là mon amis y a pas photo

j'utilise cette méthode pour faire du multi tread pour des requêtes et plein d'autres chose

dans une boucle vba la suivante et enclenché après la précédente

avec ce principe en moins d'une seconde tu peux en lancer 100
le temps qui est perdu dans la boucle vba n'est pas perdu avec le vbs
ça fait des années que j'utilise ce truc et y a même pas matière a discussion

sans jeu de mot ya pas photo comme on dit 🤣
 

Dudu2

XLDnaute Barbatruc
avec ce principe en moins d'une seconde tu peux en lancer 100
C'est pas parce que tu en lances 100 en parallèle qu'elles vont se terminer dans le même temps elapse que 2 en série. Tu les lances mais il faut bien qu'elle obtiennent des ressources pour compléter leur boulot.
Bon enfin, je veux bien te croire que ça va plus vite.
 

Dudu2

XLDnaute Barbatruc
Voilà, un peu de développement mais pas trop pour intégrer la conversion des Raw.
C'est une conversion qui prend plusieurs secondes (fichier image Raw volumineux).
Je n'ai pas utilisé la technique de multi-threads (ou multi-processus ?) de @patricktoulon pour simplifier dans un premier temps.
Chez moi ça donne ça:
1619460042346.png


Je rappelle ma question:
Pour moi la question est: dois-je développer l'affichage dynamique des miniatures ?
Perso je n'en ai pas besoin. Si quelqu'un y voit un intérêt je le fais sinon je me connecte sur Netflix.

Et merci encore à @patricktoulon sans qui je n'y serais pas arrivé avec ImageMagick.
 

Pièces jointes

  • Tags Exif Images Répertoire - Colonne Ordre.xlsm
    389.5 KB · Affichages: 19
Dernière édition:

re4

XLDnaute Occasionnel
merci à vous,,
Dudu2, ce que tu as fait est fonctionnel (avant vos dernières fonctionnalités), pour moi ça me convient, le seul hic est le poids du fichier.
Les suggestions proposées ne sont bien sur pas obligatoires et tu fais comme tu envie, tu as assez donné sur ce projet. Le principal interet aussi est de pouvoir créer des miniatures à partir des raw et des tif en restant raisonnable sur le poids. si pas possible j'utiliserai ta version avec une image de substitution (ou un texte miniature non disponible) pour les raw et les tif.

J'ai voulu testé ton fichier du post 160 mais j'ai une erreur au GO.
Ce que j'ai fait :
install de : ImageMagick-7.0.11-9-Q16-HDRI-x64-dll.exe avec les cases cochées => reboot
1619472151815.png
1619472173292.png

1619472189779.png

Quelle erreur ai-je pu faire ?
J'espère que tu as profité d'un bon film ,-)
 

Dudu2

XLDnaute Barbatruc
Pour corriger ça il faut aller dans l'onglet Développeur / Sécurité des macros / Cocher
1619498658840.png

J'ai modifié le fichier du Post 160 pour en cas d'erreur informer de la manip à faire.

Concernant le fichier ImageMagick à télécharger, j'espère que tu as bien pris celui indiqué en feuille Paramètre qui tient compte de ta version Office 32 ou 64 bits. Et non pas le premier qui se présente !
Chez moi (Office 32 bits) par exemple:
1619498803362.png


Le principal interet aussi est de pouvoir créer des miniatures à partir des raw et des tif en restant raisonnable sur le poids
Comme je l'ai indiqué auparavant, la seule garantie pour rester léger, c'est de faire l'affichage des miniatures dynamiquement lors de la consultation du fichier, c'est à dire de construire les miniatures lors de l'affichage des lignes à l'écran (pour les miniatures non déjà construites par un affichage précédent dans la session). Le fichier enregistré ne contenant aucune miniature. Sur option Oui/Non aussi. C'était l'objet de ma question mais c'est passé à la trappe.

Concernant les nombreuses suggestions tu pourras les développer toi-même. Si tu bloques je pourrai éventuellement indiquer des solutions.
 
Dernière édition:

re4

XLDnaute Occasionnel
Bonjour,
Ca fonctionne en activant ''accès approuvé''
Le dossier test fait 206 Mo et le nouveau fichier Excel 14Mo un gain ~93%,
Il fallait tester et bravo à vous deux (Toi et PatrickToulon) pour la solution.
J' y vois cependant quelques petites contraintes :
- Le fait d'installer un logiciel tiers (ça limite le partage pour les non initiés)
- Le paramétrage d'excel et des sécurités macros
- La lenteur de la conversion, c'est utilisable pour des petits dossiers

Le défit a été relevé encore bravo, et le fait d'utiliser ImageMagic ou pas est une bonne idée, je ne sais comment ça se comporte si ImageMagic n'est pas installé, est-ce que l'on peut lancer le GO sans erreur ?.

pour notre utilisation je pense que nous utiliseront principalement le fichier précédent sans les conversions, si possible et sans conversion des tif avec une image par défaut ou un texte en substitution pour les raw et tif .

Concernant les nombreuses suggestions tu pourras les développer toi-même. Si tu bloques je pourrai éventuellement indiquer des solutions.
Vaste chantier, j'ai quelques prérequis à te demander que je ferai dans un autre post, je suis un débutant et ne programme que très rarement et pas habitué à ce type de programmation, ce que je fais est très basic...
Merci à Vous et à toute la communauté pour les aides.

Dudu2, un grand merci particulier à toi pour ton implication et ton écoute.
 

Dudu2

XLDnaute Barbatruc
Chez moi ça ne plante pas. Ça ne peut pas planter sur un Trim().
Excel ne s'est pas remis d'une erreur précédente ?

Pour information, la conversion des BMP,GIF,JPG,JPEG,PNG,TIF,TIFF est assurée par les fonctions WIA. Seules les autres passent pas ImageMagick.
Pour ne pas utiliser ImageMagick, il suffit de choisir Non à la 3ème ligne des paramètres et parmi la liste des extensions à convertir en jpeg, celles qui ne sont pas converties par WIA auront la miniature par défaut. Si ImageMagick n'est pas utilisé il n'y aura pas non plus de vérification de la présence de sa DLL et donc pas de nécessité de modifier la sécurité des macros.
 
Dernière édition:

Discussions similaires

Haut Bas