Choisir repertoire, modifier un code existant ?

Option Explicit

Sub Affiche_Image()
Dim Ws As Worksheet     ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String     ' Contiendra le nom de l'image
Dim Lg As Long          ' Numéro de la dernière ligne colonne B
Dim Chemin$, Test$, F$  ' le répertoire de base + var

'saisie du chemin
Chemin$ = FLoadNomDuREP: If Chemin$ = "" Then Exit Sub

Set Ws = Sheets("Feuil1")                   ' Nom de la feuille
Application.ScreenUpdating = False          ' Interdit le raffraîchissement d'écran
Efface_Images ' <<<<<<<<<< j'espère que cette appel routine existe chez toi !?
  
With Ws
 For Lg = 1 To .Range("B" & Rows.Count).End(xlUp).Row ' Parcourt de toute la colonne B
     F$ = .Cells(Lg, "B")
     If Trim(F$) > "" Then
        Image = Dir(Chemin$ & F$)
        If Image > "" Then
           With .Pictures.Insert(Image).ShapeRange        ' On insère l'image dont le nom est en colonne B
           '.LockAspectRatio = msoFalse                   ' On peut la redimensionner comme on veut
            .LockAspectRatio = msoTrue
            .Left = Ws.Cells(Lg, "A").Left                 ' Position gauche
            .Top = Ws.Cells(Lg, "A").Top                   ' Position Haut
            .Width = Ws.Cells(Lg, "A").Width               ' Largeur
            .Height = Ws.Cells(Lg, "A").Height             ' hauteur
           End With
        Else
           MsgBox F$ & " est inexistante!?"
        End If
     End If
 Next Lg
End With
End Sub

Public Function FLoadNomDuREP() As String
With Application.FileDialog(msoFileDialogFolderPicker)
  .ButtonName = "OK"
  .InitialFileName = ThisWorkbook.Path & "\"
  .Title = "Sélectionnez un dossier"
  .Show
  If .SelectedItems.Count > 0 Then FLoadNomDuREP = .SelectedItems(1) & "\" Else FLoadNomDuREP = ""
 'ou direct
 'If .Show = -1 Then FLoadNomDuRep = .SelectedItems(1)& "\" Else FLoadNomDuRep = ""
End With
End Function

 'For I = 0 To 50
I = 0 'nom du fichier
'If myFolder.GetDetailsOf(myFile, I) <> "" Then   '(n'était pas actif)
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 20 ' Auteurs
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 25 ' Copyright
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 4 'date de création
Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 31 ' Dimensions
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 1 ' poids
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
 'Next

'Dans l'ordre d'affichage pour Win7
' 0= Nom du fichier
'20 Auteurs
'1 Taille
'162 Pixels H
'164' Pixels V

   Arr = Array(0, 20, 1, 162, 164) 'Win 7
  'Arr = Array(0, 20, 1, 167, 169) 'Win 8
  'Arr = Array(0, 20, 1, 169, 171) ' Win 10

Set objShell = CreateObject("Shell.Application")

Set objfolder = objShell.Namespace(CStr(Répertoire))


Application.ScreenUpdating = False
  Application.EnableEvents = False

' Extraction des exifs photos
Sub Extract()

'--------------------------------------------------------------------------------
Dim Rep As Integer
       Rep = MsgBox("Ceci va effacer les données existantes''.                                             Voulez-vous continuez ?", vbYesNo + vbQuestion, "AVERTISSEMENT")
    If Rep = vbYes Then
    
    ' Desactive les filtres
              'If Sheets("Extract").AutoFilterMode Then Sheets("Extract").[A2].AutoFilter
         If Sheets("Extract").AutoFilterMode = True Then Sheets("Extract").[A2].AutoFilter
         
            [a3:e1000].ClearContents
    
        ' si réponse positive Extraction des Exifs
        ' ...
    Else
        ' si réponse négative, l'on sort
        ' ...
        Exit Sub
    End If
'-------------------------------------------------------------------------------

 Dim Arr(), Elt As Variant, i As Long
 Dim det_Headers(0 To 7), X As String
 Dim Répertoire As String

Répertoire = SelDossier(Répertoire)
If Répertoire = "" Then MsgBox "Opération annulée.": Exit Sub


'La liste des numéros de champs dont l'on veut extraire la valeur
'0= nom fichier, win7, 8, 10
'1 = Taille, win7, 8, 10
'20 = Auteurs, win7, 8, 10
'162 = Pixels H (win7) 167 (win8) 168 (win10)
'164 = Pixels V (win7) 169 (win8) 171 (win10)

  'Arr = Array(0, 1, 20, 166, 167, 169) old
   Arr = Array(0, 20, 1, 162, 164) 'Win 7
  'Arr = Array(0, 20, 1, 167, 169) 'Win 8
  'Arr = Array(0, 20, 1, 169, 171) ' Win 10

Set objShell = CreateObject("Shell.Application")

Set objfolder = objShell.Namespace(CStr(Répertoire))


Application.ScreenUpdating = False
  Application.EnableEvents = False


With ThisWorkbook
      With .Sheets("Extract") 'Adapter le nom de la feuille
          .Activate
          'For Each Elt In Arr
          '    det_Headers(i) = objfolder.GetDetailsOf(objfolder.Items, Elt)
          '    .Cells(1, i + 1) = det_Headers(i)
           '   i = i + 1
         ' Next
         
    
        j = 3: i = 0 'j=3 données en ligne 3
      
      
        For Each strFileName In objfolder.Items
              For Each Elt In Arr
                  Select Case Elt
'Rentrer tous les numéros des champs qui ont une valeur numérique, supprime les Caractères
                    Case 162, 164  'pour les données numériques win7
                    'Case 167, 169  'pour les données numériques win 8
                    'Case 169, 171 'pour les données numériques win 10
                                           
                          X = objfolder.GetDetailsOf(strFileName, Elt)
                          If Not IsNumeric(Left(X, 1)) Then
                             X = Right(X, Len(X) - 1)
                          End If
                          .Cells(j, i + 1).Value = Val(Replace(Trim(X), ",", "."))
                      Case Else
                          .Cells(j, i + 1).Value = Trim(objfolder.GetDetailsOf(strFileName, Elt))
                  End Select
                  i = i + 1
              Next
               j = j + 1: i = 0
               
          Next
          
       
          
      ' '   .UsedRange.EntireColumn.AutoFit
      End With
  End With



Application.ScreenUpdating = True
 Application.EnableEvents = True
 
  '' Columns("S:U").Select
   '' Range("S3").Activate
  ''  Selection.EntireColumn.Hidden = True
    
 Range("A3").Select
 
 ' MsgBox "Fichier Excel à enregistrer dans le dossier des photos"
 

 End Sub
 


'------------------------------------------------------------------

Function SelDossier(Defaut As String)
 Dim FD As FileDialog
 Set FD = Application.FileDialog(msoFileDialogFolderPicker)
 With FD
     .InitialFileName = Defaut
     If .Show = -1 Then
         SelDossier = FD.SelectedItems(1)
    End If
 End With
 Set FD = Nothing
 End Function

'------------------------------------------------------------------