XL 2016 Boite de dialogue "propriétés"

Option Explicit
Public Const F_TEST = "Test Propriétés"
Public Const F_PROP = "Propriétés_Fichiers"
Public Function ChoixDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
    ' Indiquer le chemin complet du dossier par défaut
     .InitialFileName = "C:\Users\" & Environ("username") & "\Documents\"
     .Show
     If .SelectedItems.Count > 0 Then
        ChoixDossier = .SelectedItems(1) & "\"  ' le \ pour le renommage avec le path complet
     Else
        ChoixDossier = ""
     End If
    End With
End Function
Sub SelectionnerFichiersProp()
' Sélection du répertoire
' Copie du nom de TOUS les fichiers du répertoire en colone A et B
Dim Repertoire As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim Chaine As String
Dim Trouve As Boolean
Dim Fso As Object, FsoFolder As Object, FsoF As Object

    Repertoire = ChoixDossier()
    If Repertoire = "" Then Exit Sub
    With Sheets(F_TEST)
        .Cells.ClearContents
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set FsoFolder = Fso.GetFolder(Repertoire) '
        i = 1
        For Each FsoF In FsoFolder.Files
            i = i + 1
            .Cells(i, 1) = FsoF.Name
        Next
        ' Cellule A1 contient le nom du répertoire
        Cells(1, 1) = Left(Repertoire, Len(Repertoire) - 1) ' pour enlever le \ en fin
    End With
End Sub
Public Sub ListAvailableFileProperties()
' copie la liste des propriétés des fichiers (n° et intitulé) dans la feuille "Propriétés_Fichiers"
    On Error GoTo Error_Handler
    Dim objShell                As Object    'Shell
    Dim objFolder               As Object    'Folder
    Dim sFile                 As String
    Dim sFilePath             As String
    Dim i                     As Long

    sFile = ThisWorkbook.FullName
    sFilePath = Left(sFile, InStrRev(sFile, "\") - 1)

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CStr(sFilePath))
    If (Not objFolder Is Nothing) Then
        For i = 1 To 320  'This could be bumped up in case MS increase the number again
            'Debug.Print i, objFolder.GetDetailsOf(objFolder.Items, i)
            Sheets("Propriétés_Fichiers").Cells(i + 1, 1) = i
            Sheets("Propriétés_Fichiers").Cells(i + 1, 2) = objFolder.GetDetailsOf(objFolder.Items, i)
        Next
    End If

Error_Handler_Exit:
    On Error Resume Next
    If Not objFolder Is Nothing Then Set objFolder = Nothing
    If Not objShell Is Nothing Then Set objShell = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ListAvailableFileProperties" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub
'-----------------------------------
Sub ListerProp()
Dim i As Integer, j As Integer, iMax As Integer
Dim TabProp
Dim NomRep As String, NomFic As String
Const ColProp1 = 3
Dim ListeNo As String
    ' liste des propriétés recherchées
    ListeNo = ""
    iMax = Sheets(F_PROP).Range("A1").End(xlDown).Row
    For i = 2 To iMax
        ListeNo = ListeNo & Sheets(F_PROP).Cells(i, 1)
        If i < iMax Then ListeNo = ListeNo & ","
    Next i
    TabProp = Split(ListeNo, ",")
    Application.ScreenUpdating = False
    With Sheets(F_TEST)
        ' on vide le tableau des propriétés
        .Range(Cells(1, ColProp1), Cells(1, ColProp1 + UBound(TabProp))).EntireColumn.ClearContents
        ' 1ère ligne avec l'intitulé de la propriété
        For i = LBound(TabProp) To UBound(TabProp)
            .Cells(1, ColProp1 + i) = Sheets(F_PROP).Cells(TabProp(i) + 1, 2)
        Next i

        NomRep = .Range("REPERTOIRE") ' pour enlever le \ en fin
        For i = 2 To .Range("A1").End(xlDown).Row
            NomFic = .Cells(i, 1)
            If NomFic <> "" Then
                For j = LBound(TabProp) To UBound(TabProp)
                    .Cells(i, ColProp1 + j) = PropriétéFichier(NomRep, NomFic, CInt(TabProp(j)))
                Next j
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
'---------------------------------------

Function PropriétéFichier(pRepertoire As String, pNomFichier As String, pProp As Integer) As String
    'NE Nécessite PAS d'activer la référence Microsoft Shell Controls and Automation

    Dim objShell As Object
    Dim objFolder As Object
    Dim strFileName As Object
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CStr(pRepertoire))       'le CSTR st nécessaire !!!
    Set strFileName = objFolder.Items.Item(CStr(pNomFichier))   'le CSTR st nécessaire !!!
    
    PropriétéFichier = objFolder.GetDetailsOf(strFileName, pProp)
    'pour éliminer les caractères parasites comme les faux "? "qui encadrent la propriété "Dimensions"
    PropriétéFichier = Replace(Replace(Replace(Replace(PropriétéFichier, ChrW(8236), ""), ChrW(8234), ""), ChrW(8207), ""), ChrW(8206), "")

    Set objShell = Nothing
    Set objFolder = Nothing
    Set strFileName = Nothing
End Function

Sub TestMsgBoxPropriétéFichier()
    MsgBoxPropriétéFichier "C:\Users\crocrocro\Documents\", "P4210084.JPG"
End Sub
Sub MsgBoxPropriétéFichier(pRepertoire As String, pNomFichier As String)
    'NE Nécessite PAS d'activer la référence Microsoft Shell Controls and Automation

    Dim objShell As Object
    Dim objFolder As Object
    Dim strFileName As Object
    Dim NoProp As Integer
    Dim NomProp As String
    Dim ValeurProp As String
    Dim Message As String
    Dim Titre As Integer
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CStr(pRepertoire))       'le CSTR st nécessaire !!!
    Set strFileName = objFolder.Items.Item(CStr(pNomFichier))   'le CSTR st nécessaire !!!
 


    Message = ""
    'Liste des propriétés que vous voulez cf. feuille F_PROP
    ' et pour coller à l'explorateur, faites votre sélection avec un Select Case du type d'élément
    NoProp = 2
    NomProp = Sheets(F_PROP).Cells(NoProp + 1, 2)
    ValeurProp = objFolder.GetDetailsOf(strFileName, NoProp)
    ValeurProp = Replace(Replace(Replace(Replace(ValeurProp, ChrW(8236), ""), ChrW(8234), ""), ChrW(8207), ""), ChrW(8206), "")
    Message = Message & NomProp & vbTab & ValeurProp & vbLf
    NoProp = 4
    NomProp = Sheets(F_PROP).Cells(NoProp + 1, 2)
    ValeurProp = objFolder.GetDetailsOf(strFileName, NoProp)
    ValeurProp = Replace(Replace(Replace(Replace(ValeurProp, ChrW(8236), ""), ChrW(8234), ""), ChrW(8207), ""), ChrW(8206), "")
    Message = Message & NomProp & vbTab & ValeurProp & vbLf
    NoProp = 3
    NomProp = Sheets(F_PROP).Cells(NoProp + 1, 2)
    ValeurProp = objFolder.GetDetailsOf(strFileName, NoProp)
    ValeurProp = Replace(Replace(Replace(Replace(ValeurProp, ChrW(8236), ""), ChrW(8234), ""), ChrW(8207), ""), ChrW(8206), "")
    Message = Message & NomProp & vbTab & ValeurProp & vbLf
    NoProp = 5
    NomProp = Sheets(F_PROP).Cells(NoProp + 1, 2)
    ValeurProp = objFolder.GetDetailsOf(strFileName, NoProp)
    ValeurProp = Replace(Replace(Replace(Replace(ValeurProp, ChrW(8236), ""), ChrW(8234), ""), ChrW(8207), ""), ChrW(8206), "")
    Message = Message & NomProp & vbTab & ValeurProp & vbLf
    MsgBox Message, vbInformation, "Propriétés du fichier " & pNomFichier

    Set objShell = Nothing
    Set objFolder = Nothing
    Set strFileName = Nothing
End Sub