XL 2010 exif photo situées dans des sous-dossiers

[Sheldor]

bonjour à tous,
désolé par avance si j'ai mal cherché... je souhaite récupérer des données exif d'image situées dans des sous-dossiers.
J'ai trouvé du code pour le faire dans un dossier mais pas dans des sous dossiers

j'ai des centaines de sous dossiers et je ne peux pas les faire un par un...

voilà où j'en suis en pj

grand merci par avance

nico

 

[Staple1600]

Bonsoir le fil

nicopec
Tu lâches pas l'affaire
A moins que tu ais oublié (C'est loin 2014)

Personnellement, je tenterai la chose avec Powershell.
(comme d'autres semblent déjà l'avoir fait)
(je suis en train de titiller la bête)

Ou je me simplifierai la vie avec ExifTool (de Phil Harvey)

 

[Sheldor]

bonjour Staple,
je n'ai pas oublié, j'arrive à récupérer ce que je veux dans un dossier
avec "myFolder.GetDetailsOf(myFile, i)"
i étant 237 pour la longueur focale par exemple

mais c'est juste que je n'arrive pas à le faire dans les sous-dossiers, c'est ballot j'ai l'impression que le plus dur est fait...

je viens de regarder powershell et ça me fait peur vu mon niveau

sinon effectivement je pourrais récupérer les données avec un soft comme siren, s'il arrive à encaisser mes 150 000 images

merci bonne soirée
à demain
nico

 

[Staple1600]

Re

Il y a plusieurs exemples de procédure récursive pour parcourir un dossier et ses sous dossiers dans les archives du forum.
Reste plus qu'à les trouver.
Ce qui est relativement simple avec les bons mots-clés

Lister les fichiers et sous-répertoire d'un répertoire

Amis d'excel, Bonjour, Je vous sollicite pour lister les fichiers et sous-répertoire d'un répertoire Je voudrais pouvoir choisir la racine avec une "invite" et choisir l'emplacement (une cellule de la feuille en cours) pour commencer le listing. Merci pour votre aide. Faberiz

www.excel-downloads.com

Ensuite il suffit de mixer le tout.

 

[patricktoulon]

bonsoir
déjà pour visiter tout les dossiers /sous dossiers , il te faut une fonction récursive
Dudu2 et moi en avons mis une au point recherchant des fichier précis avec FSO dépassant mémé la vitesse de la fonction dir (ce qui est en soit un exploit avec FSO)à notre grande surprise nous pensions même pas arriver a ce résultat là bien que c'était le but de cette étude
le reste devrait etre facile une fois tout les chemin de jpg acquis
voici ma version
adapter le dialogchoix dossier ne devrait pas être très difficile

'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'Auteurs Dudu2 et patricktoulon  sur exceldownload
'version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))pour palier au limite de la fonction transpose d'excel

'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du bloc  <<if takeit>> par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
Option Explicit
Option Compare Text
Dim Appelcount
Dim countdoss
Function TransposeArray(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
    Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
    For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
    TransposeArray = tbl
End Function
'
Sub listeFSOGOSUB()
    Dim Table As Variant, tim
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Const Répertoire = "h:\": tim = Timer
    Const Ext$ = "*.jpg"
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(s) <""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/" & _
               vbCrLf & "pour " & Appelcount & " appels de la fonction dans dossier et sous dossier" & vbCrLf & countdoss & " dossiers utilement explorés"
       
        ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table

    Else
        MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">" & vbCrLf & "ayant une partie du nom contenant  " & Ext
    End If
End Sub

Function FSO_List_FICHIERS2(ByVal Folder As Variant, Optional PartName As String = "") As Variant
    Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
    Appelcount = Appelcount + 1
     countdoss = countdoss + 1
Dim oDir As Object, oSubDir As Object, oFile As Object, First_Call As Boolean, TakeIT As Boolean

    If TypeOf Folder Is Object  Then                            'si ce nest pas le premier appel  Foler est un objet folder membre de FSO
        First_Call = False                                      'si ce nest pas le premier appel  on positionne First_Call a false des les 2d appel
        Set oDir = Folder                                       'si ce nest pas le premier appel  Odir est donc un object Folder membre de FSO
    Else                                                        'si c'est le premier appel Folder est de type string
        First_Call = True                                       'si c'est le premier appel first_call est a true
        Erase tbl                                               'si c'est le premier appel on eraze la variable tableau  <<tbl>>
        NbFichiers = 0                                          'si c'est le premier appel on met la variables NbFichiers à 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")   'si c'est le premier appel on créée l'object FSO
        If Right(Folder, 1) <> "\" Then Folder = Folder & "\"   'si c'est le premier appel si le slach de fin on l'ajoute
        Set oDir = oFSO.getfolder(Folder)                       'si c'est le premier appel on instruit l'object Folder<<Odir>>avec le string du dossier
    End If

    TakeIT = True                                               'on met la variable Takeit à true d'office
    ' on ouvre une gestion d'erreur globale (pour les permissions refusées ou les noms portants des caracteres speciaux)
    'la gestion est valable aussi pour la boucle subFolder elle es fermé a chaque fin d'appels récursifs
    On Error Resume Next
    If Len(PartName) > 0 Then TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0    'si partname demandé on test de presence de (fichier avec PartName dans le nom) dans le dossier en une seule fois
    If Err.Number <> 0 Or TakeIT = False Then Err.Clear: countdoss = countdoss - 1: GoSub Scanfolder ' si erreur ou TakeIt =false on zappe l'exploration des fichiers on va directement à l'exploration des sous dossiers avec gosub

 
    For Each oFile In oDir.Files            'boucle sur les fichiers
        If Err.Number = 0 Then              'si pas d'erreur
            If Len(PartName) = 0 Then       'si pas de PartName demandé on memorise le fichier directement
                NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
            Else                            'si PartName demandé on teste si le nom de fichier like PartName
                If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path                'Stocke le nom complet du fichier en table
            End If
        End If
        Err.Clear                                       ' on clear l'erreur au cas ou
    Next oFile

Scanfolder:                                             ' etiquette du jumping d'exploration

    For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
         
            If Err.Number = 0 Then
            FSO_List_FICHIERS2 oSubDir, PartName        ' on relance la fonction ( appel récursif)
        Else: Err.Clear                                 ' sinon on clear l'erreur si dossier interdit ou special
        End If
    Next oSubDir

    On Error GoTo 0                                     ' ferme la gestion d'erreur globale

' si c'est le premier appel  donc on a lu tout l'arborescence en appels récursifs on peut maintenant instruire le return de la fonction avec le tableau
    If First_Call Then
        FSO_List_FICHIERS2 = False                      ' on met le return de la fonction a false
        If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl ' si NbFichiers est plus grand que 0 le return de la fonction est la tableau
    End If

End Function

 

[Staple1600]

Bonsoir patricktoulon


On est bien d'accord

Il y a plusieurs exemples de procédure récursive

 

[patricktoulon]

re
bonsoir Staple1600
oui de toute facon y a pas d'autre choix
tout du moins si car avec dudu2 on a bossé 3 jours sur cette question et on a trouvé 2 méthode ultra rapide
la première je viens de la donner et la seconde qui est plus une astuce que orthodoxe

 

[Staple1600]

Re

Moi, j'ai juste ouvert le tiroir de ma commode PowerShell

Spoiler: Un one-liner récursif en plus ;)

get-childitem $Env:USERPROFILE\Pictures\ -recurse | select-object DirectoryName,Name | where { $_.DirectoryName -ne $NULL } | Export-CSV $Env:USERPROFILE\Documents\LMedias.csv

 

[patricktoulon]

a oui ben tiens
en ligne de commande

Spoiler: il y a la batte de Baseball et la bath de windows

chcp 1252 > nul
dir h:\*.txt /S /B /A:-D >C:\Users\polux\Desktop\list.txt

 

[Staple1600]

Re

Avec PowerShell 7.1.2 (64bits), c'est quasi-immédiat
Je vais tester quand j'y penserais tout le répertoire Documents.

 

[patricktoulon]

essai avec bat tu va voir ce que c'est immédiat
et encore je liste un disque un dossier même avec sous dossier c'est une mouche que tu n'a même pas entendu passer c'est de l'ordre de 0.001XXXXX
adapter dans une fonction vba (cest la 2d méthode
et encore elle est ralentie par les replace pour les chemins avec des caractères particuliers

'*********************************************************************
'       fonction Dir fichier par l'intermediaire d'un fichier BATH
'DIR fichier en ligne de commande(récursif)
'auteur: Patricktoulon et Dudu2 sur exceldownlods
'date:06/02/2021
'mise a jour
'date:07/02/2021:ajout de la correction des fichier dont le nom porte des caracteres spéciaux
'date :07/02/2021:intégration d'une boucle de transposition pour palier a la limite de transpose vba
'
'**********************************************************************
Option Explicit
Sub testDIRcmd()
    [A1].CurrentRegion.Clear
    Dim Racine$, tim#, T
    Racine = "h:\*.txt"
    'Racine = "h:\"
    tim = Timer
    T = ListFichierBath(Racine)
    If IsArray(T) Then
        [A1].Resize(UBound(T), 1).Value = T
        MsgBox CDec(Timer - tim) & " seconde(s) pour " & UBound(T) & " fichier ou dossiers(s)"
    Else: MsgBox "Pas de fichier avec cette extension "
    End If
End Sub


Function ListFichierBath(Racine$, Optional Recycles As Boolean = False)
    Dim laChaine$, x&, Fichier$, bat$, Commande$, tim#, tbl, tblV, I&, arr1, arr2, a&, doss

    arr1 = Array("a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o`", "o^", "o¨", "u`", "u^", "u¨")      'array caracteres séparés
    arr2 = Array("à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "ò", "ô", "ö", "ù", "û", "ü")      'array caracteres regroupés

    bat = "C:\Users\polux\Desktop\baton.cmd"    'chemin du bath
    Fichier = Environ("userprofile") & "\Desktop\list.txt"    ' chemin du fichier liste

    Commande = "chcp 1252  > nul" & vbCrLf & "dir " & Racine & " /S /B /A:-D >" & Fichier    ' code la commande

    x = FreeFile: Open bat For Output As #x: Print #x, Commande: Close #x    'creation du bath

    ShellAndwaitingEndProcess bat    'appel fonction shell améliorée pour exécuter le bath

    'lecture du fichier
    x = FreeFile: Open Fichier For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine: Close #x

    'on fait le replace dans la chaine globale si defaut de caracteres present(plus rapide que le replace dans les ligne du tableau)
    For a = 0 To UBound(arr1)
        If InStr(1, laChaine, arr1(a)) Then laChaine = Replace(Replace(laChaine, arr1(a), arr2(a)), UCase(arr1(I)), UCase(arr2(I)))
    Next

    tbl = Split(laChaine, vbCrLf)    'coupe(array 1 dim)
    If Not Recycles Then
    For I = 0 To UBound(tbl)
       If tbl(I) Like "*$RECYCLE*" Then laChaine = Replace(laChaine, tbl(I) & vbCrLf, "")
    Next
    tbl = Split(laChaine, vbCrLf)    'coupe(array 1 dim)
    End If
    'convert array 1 dim to 2 dim(transpose)
    If laChaine <> vbNullString Then
        ReDim tblV(UBound(tbl), 1 To 1): For I = 0 To UBound(tbl): tblV(I, 1) = tbl(I): Next
        ListFichierBath = tblV
    End If
    'Kill bat
    Kill Fichier
End Function


Function ShellAndwaitingEndProcess(ByVal CheminComplet As String) As Long
    Dim ProcessHandle&, ProcessId&
    ProcessId = Shell(CheminComplet, vbHide)
    ProcessHandle = ExecuteExcel4Macro("CALL(""Kernel32"",""OpenProcess"",""JJJJ"",""" & 2031616 & """,""" & 0 & """,""" & ProcessId & """)")
    ShellAndwaitingEndProcess = ExecuteExcel4Macro("CALL(""Kernel32"",""WaitForSingleObject"",""JJJJJ"",""" & ProcessHandle & """,""" & &HF0000 & """)")
End Function

 

[Staple1600]

Re

Ca me rappelle les temps de la fenêtre noire
dir /a /b /s>c:\Users\UmmaGumma\listeF.csv
NB: Là, j'étais à la racine de Documents (dans le noir)
C'est aussi pas mal rapide.

EDITION; je n'avais pas vu ton prédécent message
PS: Pour lancer des commandes MS-Dos, j'utilise VBScript (dans VBA), c'est plus simple niveau syntaxe.

 

[patricktoulon]

et oui c'est indémodable

 

[Staple1600]

Re

PS: Tu as bien dans tes archives DV, un bout de code qui utilise la librairie WIA library (pour titiller les EXIF) ?
(Tiens je viens de voir que chez moi, elle est dans System32)
Il existe pas une version 64bits?

 

[patricktoulon]

je sais pas je pense pas wia me sert surtout en écriture quand je peux un peu sortir des api gdi et gdi+

cela dit il me semble pas que l'on ai accès a autant de données qu'avec shell.application