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

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

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