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

[bernardrustrel]

Bonjour à tous.
Je me tourne vers vous afin de savoir si il est possible en VBA d'afficher la boite de dialogue inhérente aux propriétés d'un fichier.
En outre j'arrive à lire les propriétés du fichier, Mais je voudrais tout de mème en afficher les propriétés par exemple ainsi.

AfficheBoiteDialogueProprietes(NomduFichierConcerné)

Merci à vous et bonne fetes à tous

 

[crocrocro]

Bonjour le fil,
en pj une proposition.
2 feuilles :
Test Propriétés :
- Un bouton pour sélectionner un répertoire
tous les fichiers du répertoire seront affichés en colonne A
- Un bouton pour Lister toutes les propriétés (il y en a plus de 300 pour un fichier) de tous les fichiers du répertoire
Toutes les propriétés des fichiers de la colonne A seront listées dans les colonnes suivantes C, D ....
L'en-tête des colonnes est dynamique, elle correspond au nom de la propriété.
Le code peut être modifié pour sélectionner seulement quelques propriétés.
La macro peut durer quelques minutes selon le nombre de fichiers et le nombre de propriétés à lister.

Propriétés_Fichiers :
- Liste toutes les propriétés (il y en a plus de 300 pour un fichier) disponibles des fichiers (n° et nom).

Le code du module

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

 

[bernardrustrel]

Bonjour le fil,
en pj une proposition.
2 feuilles :
Test Propriétés :
- Un bouton pour sélectionner un répertoire
tous les fichiers du répertoire seront affichés en colonne A
- Un bouton pour Lister toutes les propriétés (il y en a plus de 300 pour un fichier) de tous les fichiers du répertoire
Toutes les propriétés des fichiers de la colonne A seront listées dans les colonnes suivantes C, D ....
L'en-tête des colonnes est dynamique, elle correspond au nom de la propriété.
Le code peut être modifié pour sélectionner seulement quelques propriétés.
La macro peut durer quelques minutes selon le nombre de fichiers et le nombre de propriétés à lister.

Propriétés_Fichiers :
- Liste toutes les propriétés (il y en a plus de 300 pour un fichier) disponibles des fichiers (n° et nom).

Le code du module

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

Bonsoir et merci pour cette réponse, je me suis servi de quelque chose de similaire afin de lire les propriétés d'un fichier.
En outre ce que je désire c'est pouvoir afficher la fenêtre des propriétés d'un fichier, comme celle que l'on obtient en faisant un click droit sur un fichier puis en choisissant "propriétés"
Merci à vous et bonnes fêtes

 

[crocrocro]

@bernardrustrel ,
le code ci-dessous renvoie une Msgbox avec certaines propriétés du fichier en exemple.

Pour coller aux infos de l'Explorateur, faites votre sélection avec un Select Case du type d'élément.
Pour la Liste des propriétés que vous voulez cf. feuille F_PROP
je vous laisse convertir les 3 lignes nomprop, valeurprop valeurprop en fonction

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