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

re4

XLDnaute Occasionnel
Bonjour,
Si ça peux servir...
Compte les occurrences si trouve Tags#270 Orientation dans la ligne des titres de tags
Merci de corriger si le code peut être simplifié.

VB:
'x fait une recherche d'occurrence suivant chaine en ligne 2, utilise CountIf (NB.SI)
Sub InsertOccurrence()
Dim O As Object 'déclare la variable O (Onglet)
Dim r As Range 'déclare la variable R (Recherche)
Dim COL As Byte 'déclare la variable COL (COLonne)
Dim result As Double 'Assign the variable
Dim dernlign As Long 'Dernière ligne
Set O = Sheets("Liste") 'définit l'onglet O (à adapter)

'définit la recherche R (recherche "Obligation" dans la ligne 2 (à adapter) de l'onglet O)
Set r = O.Rows(2).Find("Tag #270" & Chr(10) & "Orientation", , xlValues, xlWhole)

If Not r Is Nothing Then 'condition : si il existe au moins une occurrence trouvée
    COL = r.Column 'définit la colonne COL
End If

'x Dernière ligne non vide
With ActiveSheet: dernlign = .Cells(.Rows.Count, COL).End(xlUp).Row: End With

'x Affiche le nombre d'occurrence si Tag#270 Orientation est trouvé en ligne 2
   Paysage = Application.WorksheetFunction.CountIf(Range(Cells(2, COL), Cells(dernlign, COL)), "Paysage")
   Portrait = Application.WorksheetFunction.CountIf(Range(Cells(2, COL), Cells(dernlign, COL)), "Portrait")
   Carré = Application.WorksheetFunction.CountIf(Range(Cells(2, COL), Cells(dernlign, COL)), "Carré")

'x Résultat dans la cellule au-dessus de la cellule Tag#270 Orientation
  Cells(1, COL) = "Paysage : " & Paysage & Chr(10) & "Portrait : " & Portrait & Chr(10) & "Carré : " & Carré

End Sub
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
C'est ton code, si ça fonctionne c'est parfait.
Pour éviter les plantages au démarrage peut-être modifier comme suit pour retarder l'apparition du UserForm.
VB:
Private Sub Workbook_Open()
    If ActiveSheet.Name = NomFeuilleListe Then Call Application.OnTime(Now + TimeValue("00:00:03"), "AfficheUserForm_Boutons")
End Sub
 

re4

XLDnaute Occasionnel
Bonjour,
Non ce n'est pas mon code (pas assez calé en VBA pour l'écrire seul) mais j'ai adapté celui du post 58 (insertion colonne).
Une idée et si au lieu de définir le ''Chemin des fichiers) par défaut en colonne A on imposait le nom du fichier qui dans tout les cas est obligatoire ? Je vais essayer si j'y arrive ;-)
 

re4

XLDnaute Occasionnel
Bonjour Dudu2, Bonjour à tous,
Le fichier (post 44) fonctionne parfaitement si l'on choisi ''sans miniature'' mais il y a un arrêt de la macro si l'on choisi miniature avec des fichiers *.cr2 ou *.arw (majuscule ou minuscule) dans le répertoire avec les *.tif c'est ok aussi.

ici :
Cellule.EntireRow.RowHeight = ActiveSheet.Shapes("IMG" & Cellule.Address).Height + MargeHauteurMiniature

Merci encore pour ce travail
Bonne journée
 

re4

XLDnaute Occasionnel
Oui mais chaque image fait au moins 20 à 25Mo, ça plante avec toutes les images avec les extensions arw et cr2, je n'ai pas pu essayer avec les raw de chez Nikon qui sont en *.nef

Edit
Y a un petit souci avec les raw même avec Lightroom on ne peut pas supprimer certaines données confidentielles (exifs et iptc), en tout cas je n'ai pas trouvé comment faire.
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Ces fichiers ne sont pas reconnus directement par Windows. Il faut passer par des applications tierces.
Je suppose qu'il n'y a pas de miniature Windows quand tu affiches le répertoire en icônes...?

Ça m'étonnerait que Excel puisse les inclure comme images.
Pour ces fichiers il va falloir utiliser une conversion préalable avant de les inclure en miniature dans la feuille.
Et pour ça il faut trouver le programme capable de faire la conversion en ligne de commande.
 

re4

XLDnaute Occasionnel
Bonsoir,
Capture.JPG


Bizarrement l'explorateur Windows affiche bien les vignettes raw (cr2 et arw)
Dans la fenêtre et le volet de détail, la restriction viendrait d'Excel (?).
La différence entre le 28 et 44 est seulement le mode de sélection dans les colonnes ''Ordre'' ou ''Afficher'' dans la feuille ''Paramètres'' ?

PS : Si tu es ok, j'ai édité le post 1 en donnant les posts des solutions.
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Bizarrement l'explorateur Windows affiche bien les vignettes raw (cr2 et arw)
Je ne peux pas trouver le problème si je n'ai pas d'image .cr2 et .arw pour faire des tests.
Il y a différents sites pour poster 2 fichiers de 20 Mo. https://cjoint.com (15 Mo) ou autre.
La différence entre le 28 et 44 est seulement le mode de sélection dans les colonnes ''Ordre'' ou ''Afficher'' dans la feuille ''Paramètres'' ?
La différence est en effet juste la gestion du tableau des Tags. Le système "Ordre" étant celui qui a ta préférence et l'autre ayant la mienne. A part ça les codes relatifs au traitement des images sont les mêmes.
PS : Si tu es ok, j'ai édité le post 1 en donnant les posts des solutions.
Ok.
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
mais il y a un arrêt de la macro si l'on choisi miniature avec des fichiers *.cr2 ou *.arw (majuscule ou minuscule) dans le répertoire avec les *.tif c'est ok aussi
Ta manière de dire qu'avec les tiff c'est ok aussi, m'a laissé pensé qu'avec les tiff ça marchait !
En fait avec les *.tiff c'est erreur aussi !

mais il y a un arrêt de la macro ici :
Cellule.EntireRow.RowHeight = ActiveSheet.Shapes("IMG" & Cellule.Address).Height + MargeHauteurMiniature
Si tu m'avais donné le message d'erreur j'aurais trouvé tout de suite !

Un test avec une .tiff a permis de trouver la cause toute simple du problème qui est que la (bonne vieille) fonction que j'utilise pour placer l'image en cellule faisait un contrôle sur les extensions des images et rejetait les .cr2, .arw, etc... J'ai retiré ce contrôle et j'arrive à lister les tiff.

Maintenant je ne sais pas pour les autres extensions raw. Je ne possède pas de tels fichiers.

Modifications faites sur ton fichier en Post #44 sur le mien en Post #28.
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Ok.
Je viens de corriger aussi ce problème gênant d'une demande d'enregistrement quand le fichier n'a pas été modifié.
Ce problème est fréquent et la cause en est ici le positionnement d'un UserForm par la valorisation de ses .Top, .Left qui font considérer le classeur comme modifié. Pour éviter ce phénomène il faut sauver avant le positionnement puis restorer après le ThisWorkbook.Saved.
 
Dernière édition:

re4

XLDnaute Occasionnel
Hello
Petit débogage si tu as le temps sur fichier post 44 j'ai pas testé le 28 :
chez moi, l'autofit ne se fait pas sur :
La ligne 1 (hauteur)
Colonne B avec miniature
Colonne A sans miniature

J'ai fait des un test en modifiant la ligne 'Ajuster les colonnes' c'est certainement pas académique mais ça marche ,-) Je préfèrerai ta mise à jour...

Et pour fignoler, si le texte des colonnes est plus court que le titre alors l'autofit ne se fait que sur le texte le plus long de la colonne
A mon avis il faudrait peut-être par exemple : Tag #321 chr(10) Ratio

Capture2.JPG

J'ai modifié
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
l'autofit ne se fait pas sur La ligne 1 (hauteur)
est-ce ici ? : 'Ajuster les colonnes
Tu parles d'Autofit sur lignes ou sur colonnes ? Ou les 2 ?

Concernant les colonnes, remplace:
VB:
'Ajuster les colonnes
ActiveSheet.UsedRange.Offset(, 1 + IIf(AfficherMiniature, 1, 0)).EntireColumn.AutoFit
Par:
Code:
'Ajuster les colonnes
ActiveSheet.UsedRange.Offset(, IIf(CheminFichierEnColonne1, 1, 0) + IIf(AfficherMiniature, 1, 0)).EntireColumn.AutoFit

A mon avis il faudrait peut-être par exemple : Tag #321 chr(10) Ratio
C'est déjà comme ça:
Code:
CelluleTitre.Value = "Tag #" & TabNumérosTags(i) & vbLf & TabNomsTags(TabNumérosTags(i))
1618935014230.png
 

Dudu2

XLDnaute Barbatruc
Si tu veux vraiment ajuster le ligne 1 qui ne bouge jamais en hauteur:
VB:
'Ajuster les lignes
If Not AfficherMiniature Then ActiveSheet.UsedRange.EntireRow.AutoFit Else ActiveSheet.Rows(1).EntireRow.AutoFit
 

Discussions similaires

Haut Bas