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

[Chrystel01]

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

 

[crocrocro]

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)

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]

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 :

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+

 

[TooFatBoy]

Bonjour,

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

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


Bonne soirée

 

[job75]

Chez moi la macro donne les titres quand le fichier n'existe pas dans le dossier défini.

 

[job75]

Ah oui c'est une coquille, c'est ce que j'avais à l'origine, j'ai corrigé mon post #3.

Merci TooFatBoy.

 

[crocrocro]

Bonjour à tous,
merci job75, j'ai rectifié mon code perso en appliquant vos simplifications qui comme chez TooFatBoy fonctionne en Windows 10 2016.

 

[AtTheOne]

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é !

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

 

[TooFatBoy]

Voir le fichier exemple.

Marche pas chez moi. 🙁

 

[AtTheOne]

Re,

Marche pas chez moi. 🙁

Après correction d'un copier-coller malheureux ...
Le code :

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

 

[TooFatBoy]

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

You're talking to me ???
Hélas non, ce n'est pas moi qui vais avoir des idées sur ce point... 🙁

 

[AtTheOne]

I'm talking to you. What a pity.

A bientôt

 

[TooFatBoy]

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 ?

 

[AtTheOne]

Le petit pb qui bloquait, c'était juste un "bj" en trop ?

Non un nom d'objet incorrect (objFolder au lieu de oFolder)
J'utilise deux methodes :
la propriété obtenue par FileStystemObject en octets
le propriété obtenue par Shell en Ko, Mo, Go avec un facteur de 1024 octets je crois

A bientôt

 

[AtTheOne]

re et oui un bj en trop, je n'avais pas bien compris 😛