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

Sub o()
Dim Img As ImageFile
    Dim P As Property
    Dim S As String
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.imageFile")
    'Chargement de l'image dans le conteneur
    Img.LoadFile ("C:\Users\Staple\Pictures\test.png")
    'Boucle sur la collection de propriétés
    For Each P In Img.Properties
        S = P.Name & "(" & P.PropertyID & ") = "
        If P.IsVector Then
            S = S & " - vector data not emitted - "
            
            ElseIf P.Type = RationalImagePropertyType Then
            S = S & P.Value.Numerator & "/" & P.Value.Denominator
            
            ElseIf P.Type = StringImagePropertyType Then
            S = S & """" & P.Value & """"
            
            Else
            S = S & P.Value
        End If
        Debug.Print S
    Next
End Sub

Sub TestOk()
Dim Img As ImageFile
Dim P As Property, S As String, I&
'Création conteneur pour l'image à manipuler
Set Img = CreateObject("WIA.imageFile")
'Chargement de l'image dans le conteneur
Img.LoadFile ("C:\Users\STAPLE\Pictures\CIMG1600.JPG")
'Boucle sur la collection de propriétés
[A1] = "EXIF": I = 2
On Error Resume Next
For Each P In Img.Properties
Cells(I, 1) = "(" & I - 1 & ") " & P.Name & "(" & P.PropertyID & ") = " & P.Value
I = I + 1
Next
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

'*********************************************************************
'       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 = "G:\_boulot\_5100 +++IMAGES +++++++++\041301 PHOTO id\*.jpg"
      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