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

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
B

bernardrustrel

XLDnaute Occasionnel
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
 
Trier par date Trier par votes
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
VB: 
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
 

Pièces jointes

Vote positif 0 Vote négatif
crocrocro à dit:
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
VB: 
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
@bernardrustrel ,
le code ci-dessous renvoie une Msgbox avec certaines propriétés du fichier en exemple.
1734720751245.png

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


VB: 
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
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

B
  • Question Question
XL 2016 Boite de dialogue windows
Réponses
4
Affichages
697
bernardrustrel
B
B
  • Question Question
XL 2016 Affichage de la fenêtre "Propriétés" d'un fichier.
Réponses
1
Affichages
504
sylvanu
sylvanu
D
  • Question Question
Microsoft 365 Afficher les propriétés d'un fichier
Réponses
2
Affichages
476
patricktoulon
patricktoulon
jeff1494
  • Question Question
XL 2021 Aide pour recherche intuitive
2
Réponses
16
Affichages
788
jeff1494
jeff1494
jeff1494
  • Question Question
XL 2021 Liste des propriétés de fichiers.
3 4 5
Réponses
73
Affichages
3 K
jeff1494
jeff1494
E
  • Question Question
XL 2019 enregistrer un classeur non ouvert
Réponses
1
Affichages
232
sylvanu
sylvanu
R
  • Question Question
Microsoft 365 VBA Excel PowerPoint
Réponses
5
Affichages
334
Rem6610
R
B
  • Question Question
XL 2016 Propriétés fichiers vidéos.
Réponses
3
Affichages
486
patricktoulon
patricktoulon
A
  • Question Question
Microsoft 365 Macro pour recherche de cellules entre 2 fichiers Excel
Réponses
6
Affichages
78
wDog66
wDog66
jeff1494
  • Question Question
XL 2021 Affichage document (Word ou PDF) dans un formulaire depuis un bouton.
2
Réponses
19
Affichages
165
jeff1494
jeff1494
patricktoulon
collection boite de dialog patricktoulon le dialog fichier selectif par filtre
Réponses
2
Affichages
281
DenisHen
D
C
  • Question Question
XL pour MAC Enregistrer sous VBA
2
Réponses
20
Affichages
1 K
fanch55
fanch55
F
  • Résolu(e)
Microsoft 365 Code vba pour Ouvrir un fichier et copier son contenu dans un classeur existant à partir de la boite de dialogue
Réponses
3
Affichages
982
Faroyo
F
S
  • Question Question
Microsoft 365 VBA enregistrement dans dossier spécifique
Réponses
1
Affichages
272
vgendron
vgendron
O
  • Question Question
XL 2016 Formules avec multicritères
Réponses
7
Affichages
261
oscarette
O
J
  • Question Question
XL 2016 Problème envoi mail par macro suite passage Office 365
Réponses
11
Affichages
279
Jean Michel
J
patricktoulon
  • Résolu(e)
Autres Tests de diverses solution pour lister dans un dialog perso des fichiers en filtrant par expression et extension
10 11 12
Réponses
175
Affichages
16 K
patricktoulon
patricktoulon
C
  • Question Question
Microsoft 365 Macro pour créer boite de dialogue
2
Réponses
21
Affichages
2 K
Dudu2
Dudu2
L
  • Résolu(e)
Microsoft 365 Trier données vers une autre Feuille,suivant Critères
Réponses
4
Affichages
506
Phil69970
Phil69970
B
  • Question Question
XL 2016 Commentaires dans text box
Réponses
2
Affichages
115
bernardrustrel
B
Retour