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

[re4]

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

'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

 

[re4]

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

'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

 

[Dudu2]

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.

Private Sub Workbook_Open()
    If ActiveSheet.Name = NomFeuilleListe Then Call Application.OnTime(Now + TimeValue("00:00:03"), "AfficheUserForm_Boutons")
End Sub

 

[re4]

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]

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

 

[Dudu2]

Bonjour,
Peux-tu envoyer une image de chacun des types qui font planter le code ?

 

[re4]

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.

 

[Dudu2]

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]

Bonsoir,

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.

 

[Dudu2]

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.

 

[Dudu2]

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.

 

[re4]

Bonjour
super ça marche parfaitement, oui, je n'ai pas été très clair sur les tif, je voulais dire qu'avec les tif çà fonctionnait...
Merci encore

 

[Dudu2]

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.

 

[re4]

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

J'ai modifié

 

[Dudu2]

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:

'Ajuster les colonnes
ActiveSheet.UsedRange.Offset(, 1 + IIf(AfficherMiniature, 1, 0)).EntireColumn.AutoFit

Par:

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

CelluleTitre.Value = "Tag #" & TabNumérosTags(i) & vbLf & TabNomsTags(TabNumérosTags(i))

 

[Dudu2]

Si tu veux vraiment ajuster le ligne 1 qui ne bouge jamais en hauteur:

'Ajuster les lignes
If Not AfficherMiniature Then ActiveSheet.UsedRange.EntireRow.AutoFit Else ActiveSheet.Rows(1).EntireRow.AutoFit