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

 

[AtTheOne]

Bonjour @Cousinhub
Ta solution m’intéresse, peux-tu la postée (sans les références des fichiers évidemment )
Merci d'avance

 

[Gégé-45550]

Oui mais ce qui est agaçant c'est que windows, dans les propriétés du fichier est capable de le lire, il doit bien y avoir une ressource qui permet d'obtenir cette info non ?
Regarde la pièce jointe 1197096

Comme ça :

Sub LireProprietesClasseur_DSO()
    'Nécessite d'activer la référence à dsofile_x64.dll ou dsofile.dll suivant la version d'Excel
    Dim DSO As DSOFile.OleDocumentProperties
  
    Set DSO = New DSOFile.OleDocumentProperties
  
    'Attention: Le fichier doit être préalablement fermé!
    DSO.Open sfilename:="C:\Users\User\Downloads\Lire Propriétés.xlsm"
  
    '
    MsgBox "Auteur : " & DSO.SummaryProperties.Author & vbLf & "Dernier enregistrement par : " & DSO.SummaryProperties.LastSavedBy
    '
     DSO.Close
End Sub

PS : Sur Excel 64 bits, renommer la PJ en dsofile_x64.dll et l'enregistrer dans l'éditeur VBA (Outils/Références). Sur une version 32 bits, télécharger dsofile.dll chez Microsoft puis l'enregistrer.
Cordialement,

 

[Chrystel01]

Merci pour votre aide !!!
J'ai testé les différentes macros que vous proposez.
Je pense que la lenteur de mon côté est due à la connexion sur des serveurs à distance.
Je réessayerai sur place.
Merci encore et bon week-end de Pentecôte !

 

[crocrocro]

Bonjour à tous,
pour Chrystel :
j'ai fait un test de mon code avec 100 fichiers
Sans neutraliser la mise à jour de l'écran :
10 secondes pour 100 fichiers soit 2 000 secondes -> 30 minutes pour 20 000 fichiers
En neutralisant la mise à jour de l'écran avec Application.ScreenUpdating = False (le code ci-dessous) :
5 secondes pour 100 fichiers soit 2 000 secondes -> 15 minutes pour 20 000 fichiers

Sub listeprop()
Dim i As Integer
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 9 To 109
            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
    Application.ScreenUpdating = True
End Sub

 

[TooFatBoy]

j'ai fait un test de mon code avec 100 fichiers
Sans neutraliser la mise à jour de l'écran :
10 secondes pour 100 fichiers soit 2 000 secondes -> 30 minutes pour 20 000 fichiers
En neutralisant la mise à jour de l'écran avec Application.ScreenUpdating = False (le code ci-dessous) :
5 secondes pour 100 fichiers soit 2 000 secondes -> 15 minutes pour 20 000 fichiers

Tu n'as pas essayé de tout mettre dans un tableau et de copier ensuite le contenu dudit tableau en une seule fois sur la feuille ?

 

[crocrocro]

Pour TooFatBoy, :
Non,
je suppose que le traitement ne doit pas être effectué souvent. je ne sais pas si on peut gratter beaucoup de temps.
Avec le ScreenUpdating = False puis remis à True en fin de traitement on gagne x 2. Je ne sais pas si on gagne beaucoup plus de temps en passant par un tableau mais je ne pense pas.
La question que je me pose et qui s'adresse à Chrystel :
Les fichiers donnés en exemple sont sur G: un disque réseau ?.
Si tous les fichiers sont sur le même ordinateur accédé à ici à distance, il serait plus judicieux d'exécuter le traitement directement sur cet ordinateur. Mais ce n'est peut-être pas possible.

 

[TooFatBoy]

Je ne sais pas si on gagne beaucoup plus de temps en passant par un tableau mais je ne pense pas.

Peut-être que ça divise le temps par 100 ???

 

[crocrocro]

Peut-être que ça divise le temps par 100 ???

Je viens de faire le test pour les mêmes données avec la macro de AtTheOne :
8 secondes (6 secondes avec ma macro et Application.ScreenUpdating = False

 

[TooFatBoy]

Je viens de faire le test pour les mêmes données avec la macro de AtTheOne

L'idée était bien sûr de le faire sur ton code.

 

[crocrocro]

J'ai été un peu vite
4 secondes avec le code ci-dessous où j'ai nclus la gestion par tableau.

Sub LirePropriétésFichiersFermésbis()
   
     Dim tablo, NomFich$, lgn%
   
     '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 NomFich <> "" Then
               tablo(lgn, Col_Taille) = ListeProprietesFichier_getDetailsOf(NomFich, 1)
               tablo(lgn, Col_AUTEUR) = ListeProprietesFichier_getDetailsOf(NomFich, 20)
               tablo(lgn, Col_DateCréation) = ListeProprietesFichier_getDetailsOf(NomFich, 3)
               tablo(lgn, Col_DateModif) = ListeProprietesFichier_getDetailsOf(NomFich, 4)
               tablo(lgn, Col_DateAccès) = ListeProprietesFichier_getDetailsOf(NomFich, 5)
          End If
     Next
     'Coller les résultat dans le tableau
     sh_LstFich.[_Liste].Value = tablo
   
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
    '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
    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

    ' si fichier n'exist pas on retournera vide
    ListeProprietesFichier_getDetailsOf = ""
    On Error Resume Next
 
    '-----
    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)

    ListeProprietesFichier_getDetailsOf = objFolder.GetDetailsOf(strFileName, pProp)

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

End Function

 

[Chrystel01]

Bonjour,

La macro a superbement fonctionné et j'ai pu récupérer toutes les informations pendant la nuit, même si cela a pris du temps.

Effectivement, les fichiers n'était pas sur mon ordinateur mais sur un lecteur réseau G:/ auquel j'accèdais à distance .... Cela doit être la cause de la durée du programme.

Je vous remercie tous pour votre aide et vos messages.

Excellent week-end

Chrystel

 

[job75]

Bonjour,

Si vous utilisez la solution de mon post #3 - pas de "Scripting.FileSystemObject" - ce sera plus rapide.

A+

 

[crocrocro]

Bonjour à tous,
pour job75 :
j'ai fait un test sur 100 fichiers avec et sans "Scripting.FileSystemObject" et je trouve à peu près le même temps et bizarrement plus rapide (de 10%) avec que sans :
Avec : 3.3 secondes
Sans : 3.7 secondes.
Ce test n'a bien sûr pas grande valeur, seulement 100 fichiers et pas de disque réseau, ce dernier point étant le plus pénalisant.
Les 2 versions de code utilisées

Sub LirePropriétésFichiersFermés_1()
Dim tStart As Double
Dim tablo, NomFich$, lgn%
   
     tStart = Timer
   
     '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 NomFich <> "" Then
               tablo(lgn, Col_Taille) = ListeProprietesFichier_getDetailsOf_1(NomFich, 1)
               tablo(lgn, Col_AUTEUR) = ListeProprietesFichier_getDetailsOf_1(NomFich, 20)
               tablo(lgn, Col_DateCréation) = ListeProprietesFichier_getDetailsOf_1(NomFich, 3)
               tablo(lgn, Col_DateModif) = ListeProprietesFichier_getDetailsOf_1(NomFich, 4)
               tablo(lgn, Col_DateAccès) = ListeProprietesFichier_getDetailsOf_1(NomFich, 5)
          End If
     Next


    MsgBox "LirePropriétésFichiersFermés_1 : " & (Timer - tStart) & " secondes"
   
End Sub
Sub LirePropriétésFichiersFermés_2()
Dim tStart As Double
Dim tablo, NomFich$, lgn%
Dim NomRep As String, NomFic As String
   
     tStart = Timer
   
     'Récupérer les données du tableau structuré "_Liste"
     tablo = sh_LstFich.[_Liste]
   
     For lgn = 1 To UBound(tablo)
          NomRep = tablo(lgn, Col_Path_R)
          NomFic = tablo(lgn, Col_Nom)
        If NomFic <> "" Then
               tablo(lgn, Col_Taille) = ListeProprietesFichier_getDetailsOf_2(NomRep, NomFic, 1)
               tablo(lgn, Col_AUTEUR) = ListeProprietesFichier_getDetailsOf_2(NomRep, NomFic, 20)
               tablo(lgn, Col_DateCréation) = ListeProprietesFichier_getDetailsOf_2(NomRep, NomFic, 3)
               tablo(lgn, Col_DateModif) = ListeProprietesFichier_getDetailsOf_2(NomRep, NomFic, 4)
               tablo(lgn, Col_DateAccès) = ListeProprietesFichier_getDetailsOf_2(NomRep, NomFic, 5)
          End If
     Next


    MsgBox "LirePropriétésFichiersFermés_2 : " & (Timer - tStart) & " secondes"
   
End Sub
Function ListeProprietesFichier_getDetailsOf_1(Fichier As String, pProp As Integer) As String
    'Nécessite d'activer la référence Microsoft Shell Controls and Automation
    '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
    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
    ' si fichier n'exist pas on retournera vide
    ListeProprietesFichier_getDetailsOf_1 = ""
    On Error Resume Next
    '-----
    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)

    ListeProprietesFichier_getDetailsOf_1 = objFolder.GetDetailsOf(strFileName, pProp)

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

End Function

Function ListeProprietesFichier_getDetailsOf_2(pRepertoire As Variant, pNomFichier As Variant, pProp As Integer) As String
    'NE Nécessite PAS d'activer la référence Microsoft Shell Controls and Automation
    'https://www.devhut.net/how-to-retrieve-a-files-properties-with-vba/
    Dim objShell As Object
    Dim objFolder As Object
    Dim strFileName As Object
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CStr(pRepertoire))
    Set strFileName = objFolder.Items.Item(CStr(pNomFichier))
   
    ListeProprietesFichier_getDetailsOf_2 = objFolder.GetDetailsOf(strFileName, pProp)

    Set objShell = Nothing
    Set objFolder = Nothing
    Set strFileName = Nothing
End Function