XL 2013 Fonction pour obtenir taille fichier, auteur...

Chrystel01

XLDnaute Occasionnel
Bonjour,

J'ai sur une feuille une liste de noms de fichiers en colonne D et un chemin d'accès en colonne F. Ces fichiers sont fermés.
Il existe 20 000 lignes de noms de fichiers environ mais ne joints qu'un exemple dans le fichier attaché.
J'aurais souhaité récupérer dans les colonnes H à K la taille de chaque fichier, son auteur, la date d'accès et de dernière modification.

Pourriez-vous m'aider svp avec une fonction VBA ? Je ne sais pas comment faire et cela m'éviterait tout un travail manuel.
NB : Je ne souhaite pas passer par power query qui plante et ne va jamais jusqu'au bout du comptage pour des raisons diverses.

Je vous remercie par avance pour votre aide :)

Bonne journée

Chrystel
 

Pièces jointes

  • test.xlsx
    8.8 KB · Affichages: 25
Solution
Bonjour Christel,
Ci-dessous, le code VBA de la macro listeprop à exécuter.
A noter : Nécessite d'activer la référence Microsoft Shell Controls and Automation
La boucle pour toutes les lignes à adapter (ici de 9 à 10)
VB:
Sub listeprop()
Dim i As Integer
    With ActiveSheet
        For i = 9 To 10
            If .Cells(i, 4) <> "" Then
                .Cells(i, 8) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 1)
                .Cells(i, 9) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 20)
                .Cells(i, 10) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 3)
                .Cells(i, 11) = ListeProprietesFichier_getDetailsOf(.Cells(i...

crocrocro

XLDnaute Occasionnel
Bonjour Christel,
Ci-dessous, le code VBA de la macro listeprop à exécuter.
A noter : Nécessite d'activer la référence Microsoft Shell Controls and Automation
La boucle pour toutes les lignes à adapter (ici de 9 à 10)
VB:
Sub listeprop()
Dim i As Integer
    With ActiveSheet
        For i = 9 To 10
            If .Cells(i, 4) <> "" Then
                .Cells(i, 8) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 1)
                .Cells(i, 9) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 20)
                .Cells(i, 10) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 3)
                .Cells(i, 11) = ListeProprietesFichier_getDetailsOf(.Cells(i, 6) & "/" & .Cells(i, 4), 5)
            End If
        Next i
    End With
End Sub
Function ListeProprietesFichier_getDetailsOf(Fichier As String, pProp As Integer) As String
    '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
  
    '-----
    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)
    'https://www.devhut.net/how-to-retrieve-a-files-properties-with-vba/
    ' 1 = taille
    ' 3 = date de modif
    ' 4 = date de création
    ' 5 = date d'accès
    ' 20 = auteur

    ListeProprietesFichier_getDetailsOf = objFolder.GetDetailsOf(strFileName, pProp)

    Set Fso = Nothing
    Set oFichier = Nothing
    Set objShell = Nothing
    Set objFolder = Nothing
    Set strFileName = Nothing

End Function
 

job75

XLDnaute Barbatruc
Bonjour Chrystel01, crocrocro, le forum,

Chez moi sur Win 11 et Excel 2019 il n'est pas nécessaire de cocher la référence "Microsoft Shell Controls and Automation".

Et il n'est pas nécessaire d'utiliser la bibliothèque "Scripting.FileSystemObject", voyez ce code :
VB:
Sub listeprop1()
Dim objShell As Object, i As Long, objFolder As Object, strFileName As Object
    Set objShell = CreateObject("Shell.Application")
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 9 To 20000
            If .Cells(i, 4) <> "" Then
                Set objFolder = objShell.Namespace(CStr(.Cells(i, 6)))
                Set strFileName = objFolder.Items.Item(CStr(.Cells(i, 4)))
                .Cells(i, 8) = objFolder.GetDetailsOf(strFileName, 1)
                .Cells(i, 9) = objFolder.GetDetailsOf(strFileName, 20)
                .Cells(i, 10) = objFolder.GetDetailsOf(strFileName, 3)
                .Cells(i, 11) = objFolder.GetDetailsOf(strFileName, 5)
                Set objFolder = Nothing
                Set strFileName = Nothing
            End If
        Next i
    End With
End Sub

' 1 = taille
' 3 = date de modif
' 4 = date de création
' 5 = date d'accès
' 20 = auteur
Si un chemin n'existe pas un bug se produit.

Avec 20 000 fichiers le traitement prendra plusieurs dizaines de secondes.

A+
 
Dernière édition:

TooFatBoy

XLDnaute Barbatruc
Bonjour,

Merci job75 pour cette macro qui fonctionne nickel chez moi avec Excel 2016. 👍

Capture.png

(j'ai ajouté une colonne pour la date de création)


Bonne soirée
 
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Bonsoir à toutes & à tous, bonsoir @Chrystel01,
Bon comme d'hab j'arrive après la bagarre mais je propose aussi ma solution (qui ressemble étrangement à celles qui précèdent !
J'ai transformé ta liste en tableau structuré (nommé _Liste)
Je teste l'existence du fichier.
Je mets la taille en octets et en Ko, Mo, Go

le code :
EDIT : VOIR post10 bug corrigé !
VB:
nous 
Sub LirePropriétésFichiersFermés()
 
     Dim oShell As Object, oFolder As Object, oFolderItem As Object
     Dim FSo As Object, FSoFi As Object
     Dim tablo, NomFich$, lgn%
 
     Set oShell = CreateObject("Shell.Application")
     Set FSo = CreateObject("Scripting.FileSystemObject")
 
     'Récupérer les données du tableau structuré "_Liste"
     tablo = sh_LstFich.[_Liste]
 
     For lgn = 1 To UBound(tablo)
     
          NomFich = tablo(lgn, Col_Path_R) & "\" & tablo(lgn, Col_Nom)
          If FSo.FileExists(NomFich) Then
               Set oFolder = oShell.Namespace(tablo(lgn, Col_Path_R))
               Set oFolderItem = oFolder.Items.Item(tablo(lgn, Col_Nom))
               Set FSoFi = FSo.GetFile(NomFich)
         
               tablo(lgn, Col_Taille) = Format(CLng(FSoFi.Size), "#,###") & " (" & oFolder.GetDetailsOf(oFolderItem, pTaille) & ")"
               tablo(lgn, Col_AUTEUR) = oFolder.GetDetailsOf(oFolderItem, pAuteur)
               tablo(lgn, Col_DateCréation) = FSoFi.DateCreated
               tablo(lgn, Col_DateModif) = FSoFi.DateLastModified
               tablo(lgn, Col_DateAccès) = FSoFi.DateLastAccessed
         
               Set objFolder = Nothing: Set oFolderItem = Nothing: Set FSoFi = Nothing
          End If
     Next
     Set oShell = Nothing: Set FSo = Nothing
     'Coller les résultat dans le tableau
     sh_LstFich.[_Liste].Value = tablo
 
End Sub

Voir le fichier exemple.

PS: @job75 , @TooFatBoy , @crocrocro
Je n'ai pas trouvé de méthode pour récupérer l'auteur de la dernière modification dans un fichier fermé,
quelqu'un a-t-il une idée ?

A bientôt
 

Pièces jointes

  • Lire Propriétés Fichiers Fermés.xlsm
    18.4 KB · Affichages: 7
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Re,
Marche pas chez moi. :(

Après correction d'un copier-coller malheureux ...
Le code :
VB:
Const Col_Nom = 4, Col_Path = 5, Col_Path_R = 6
Const Col_Taille = 7, Col_AUTEUR = 8, Col_DateCréation = 9, Col_DateModif = 10, Col_DateAccès = 11
Const pTaille = 1, pDateModif = 3, pDateCréation = 4, pDateAccès = 5, pAuteur = 20

Sub LirePropriétésFichiersFermés()
    
     Dim oShell As Object, oFolder As Object, oFolderItem As Object
     Dim FSo As Object, FSoFi As Object
     Dim tablo, NomFich$, lgn%
    
     Set oShell = CreateObject("Shell.Application")
     Set FSo = CreateObject("Scripting.FileSystemObject")
    
     'Récupérer les données du tableau structuré "_Liste"
     tablo = sh_LstFich.[_Liste]
    
     For lgn = 1 To UBound(tablo)
          
          NomFich = tablo(lgn, Col_Path_R) & "\" & tablo(lgn, Col_Nom)
          If FSo.FileExists(NomFich) Then
               Set oFolder = oShell.Namespace(tablo(lgn, Col_Path_R))
               Set oFolderItem = oFolder.Items.Item(tablo(lgn, Col_Nom))
               Set FSoFi = FSo.GetFile(NomFich)
              
               tablo(lgn, Col_Taille) = Format(CLng(FSoFi.Size), "#,###") & " (" & oFolder.GetDetailsOf(oFolderItem, pTaille) & ")"
               tablo(lgn, Col_AUTEUR) = oFolder.GetDetailsOf(oFolderItem, pAuteur)
               tablo(lgn, Col_DateCréation) = FSoFi.DateCreated
               tablo(lgn, Col_DateModif) = FSoFi.DateLastModified
               tablo(lgn, Col_DateAccès) = FSoFi.DateLastAccessed
              
               Set objFolder = Nothing: Set oFolderItem = Nothing: Set FSoFi = Nothing
          End If
     Next
     Set oShell = Nothing: Set FSo = Nothing
     'Coller les résultat dans le tableau
     sh_LstFich.[_Liste].Value = tablo
    
End Sub

Et pour l'auteur de la dernière modif, pas d'idée ?

A bientôt
 

Pièces jointes

  • Lire Propriétés Fichiers Fermés.xlsm
    19.2 KB · Affichages: 4

TooFatBoy

XLDnaute Barbatruc
Le petit pb qui bloquait, c'était juste un "bj" en trop ?
Merci pour ta version qui fonctionne parfaitement. 👍

Tant que tu es là, je n'ai pas compris comment tu mets en ko, Mo, Go.
Et à ce sujet, peut-on corriger la valeur, ou cela vient-il de Microsoft qui fait la même erreur que dans son Explorateur de fichiers ?
 

Discussions similaires

Réponses
19
Affichages
2 K

Statistiques des forums

Discussions
313 271
Messages
2 096 724
Membres
106 720
dernier inscrit
Alain EDZOA