XL 2016 Boite de dialogue windows

Sub Rectangleàcoinsarrondis3_Cliquer()
infosClasseurBuiltinDocumentProperties
End Sub

Sub infosClasseurBuiltinDocumentProperties()
Dim Valeur As DocumentProperty
Dim R As Byte
 
On Error Resume Next

' Pour afficher directement dans le classeur
R = 1
For Each Valeur In ActiveWorkbook.BuiltinDocumentProperties
    Cells(R, 1) = Valeur.Name
    Cells(R, 2) = Valeur.Value
    R = R + 1
Next

'Pour afficher dans msgBox (liste à compléter ou à modifier suivant besoin)
MsgBox ActiveWorkbook.BuiltinDocumentProperties("Title").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Subject").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Author").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Keywords").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Comments").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Template").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Last Author").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Revision Number").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Creation Date").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Last Save Time").Value & vbCrLf & _
ActiveWorkbook.BuiltinDocumentProperties("Security").Value
End Sub

Dim sChemin As String
Dim sFich As String
    sChemin = ThisWorkbook.Path & "\"
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = sChemin
        .Title = "Sélectionner le fichier"
        .AllowMultiSelect = False
        .ButtonName = "Sélection Fichier"
        With .Filters
            .Clear
            .Add "All", "*.*"
        End With
        .Show
        If .SelectedItems.Count > 0 Then
            sFichier = .SelectedItems(1)
            
            sFich = sFichier
            ListeProprietesFichier_getDetailsOf sFich
        End If
    End With
End Sub


Sub ListeProprietesFichier_getDetailsOf(Fichier As String)
    'source:
    'http://www.microsoft.com/resources/documentation/windows/2000/server/
    'scriptguide/en-us/sas_fil_lunl.mspx
    '
    'Nécessite d'activer la référence Microsoft Shell Controls and Automation
    '
    Dim Fso As Object, oFichier As Object
    Dim objShell As Shell32.Shell
    Dim objFolder As Shell32.Folder
    Dim strFileName As Shell32.FolderItem
    Dim Chemin As String, NomFich As String, Resultat As String
    Dim i As Byte
    
    '-----
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set oFichier = Fso.GetFile(Fichier)
    Chemin = Fso.GetParentFolderName(oFichier)
    NomFich = Fso.GetFileName(oFichier)
    '-----
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(Chemin)
    Set strFileName = objFolder.Items.Item(NomFich)
    
    For i = 0 To 34
        'Cet exemple n'affiche pas les propriétés vides
        If objFolder.GetDetailsOf(strFileName, i) <> "" Then _
        Resultat = Resultat & objFolder.GetDetailsOf(objFolder.Items, i) _
        & ":  " & objFolder.GetDetailsOf(strFileName, i) & vbLf
    Next
    
    MsgBox Resultat
End Sub