VBScript mieux que VBa pour lister un ensemble de fichiers et de ses caractéristiques ?

Version imprimable

Hello tout le monde,

Je me suis fais une petite macro VBA qui a pour fonction de lister l'ensemble des fichiers d'un répertoire donné dans une feuille Excel avec les info suivantes :
- le nom du fichier
- sa taille
- la date (extraite du nom du fichier par des regex)
- la date et heure (extraite du nom du fichier par des regex)
- les écarts entre 2 fichiers en minute et secondes sur une journée

Le script en VBA fonctionne bien si les répertoires ne sont pas trop chargé en fichiers. Je suis limite obligé de lancer mon script le soir pour laisser tourner tranquillement Excel, sinon il se met à rapidement planter.

Je pensais donc peut être qu'en lancant un fichier *.vbs dans une console et qui écrirait dans un fichier Excel fermé serait peut être mieux. Je pourrais faire d'autres chose sur mon poste.
Est ce qu'il s'agit d'une solution interessante VBS dans ce cas de figure. Je me débrouille un peu en VBA, mais VBs pas du tout. Je pensais que c'était quasiment la même chose mais je viens de voir qu'il y a des commandes un peu différente. Un petit temps d'apprentissage sera nécessaire, il ne suffira pas de faire un copié collé de mon code VBA dans un fichier VBS et roulez ...

Pour info mon script

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean, lgRepParent As Integer)
  ' adapté de Ole P Erlandsen
  ' necessite d'activer la reference Microsoft Scripting RunTime
  ' dans lediteur : menu Outils => Reference pour activer
  Static FSO As FileSystemObject
  Dim oSourceFolder As Scripting.Folder
  Dim oSubFolder As Scripting.Folder
  Dim oFile As Scripting.File
  Dim annee As Integer, mois As Integer, jour As Integer, heure As Integer, minute As Integer
  Static wksDest As Worksheet
  Static iRow As Long
  Dim dateTime As Date, dateTimePrev As Date, parentFolderPrev As String
 
  annee = mois = jour = heure = minute = 0
  dateTimePrev = 0
  parentFolderPrev = ""
 
  Columns("D:D").NumberFormat = "dd/mm/yyyy"
  Columns("E:E").NumberFormat = "dd/mm/yyyy hh:mm"
  Columns("F:F").NumberFormat = "hh:mm"
 
  'bNotFirstTime = False
  'Debug.Print strFolderName
 
  If Not bNotFirstTime Then
    Set wksDest = ActiveSheet ' A adtapter
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With wksDest
      '.Cells(1, 1) = "Parent folder"
      .Cells(1, 1) = "Répertoire"
      .Cells(1, 2) = "Fichier"
      .Cells(1, 3) = "Taille en ko"
      .Cells(1, 4) = "Date"
      .Cells(1, 5) = "Date et heure"
      .Cells(1, 6) = "Ecart dans une journee"
    End With
    iRow = 2
    bNotFirstTime = True
  End If
  Set oSourceFolder = FSO.GetFolder(strFolderName)
  For Each oFile In oSourceFolder.Files
    'Debug.Print "iRow=" & iRow & "oFile.ParentFolder.Path " & oFile.ParentFolder.Path
    If InStr(oFile.Name, "xml") Then
 
        'parsing du nom du fichier pour recuper la date
        parseDate oFile.Name, annee, mois, jour, heure, minute
        dateStr = annee & "/" & mois & "/" & jour
        dateTime = DateSerial(annee, mois, jour)
        dateTime = DateAdd("h", heure, dateTime)
        dateTime = DateAdd("n", minute, dateTime)        
 
        If parentFolderPrev = oFile.ParentFolder.Path Then
            If Day(dateTimePrev) = Day(dateTime) And DateDiff("d", dateTimePrev, dateTime) <= 1 Then
                dateTimeDiffMin = DateDiff("n", dateTimePrev, dateTime)
                dateTimeDiffHeure = Int(dateTimeDiffMin / 60)
                dateTimeDiffMin = dateTimeDiffMin Mod 60
                dateTimeDiff = TimeSerial(dateTimeDiffHeure, dateTimeDiffMin, 0) 'le calcul doit se faire ici, car variable multi type
            Else
                dateTimeDiffMin = ""
                dateTimeDiffHeure = ""
                dateTimeDiff = ""
            End If
        Else
            dateTimeDiffMin = ""
            dateTimeDiffHeure = ""
            dateTimeDiff = ""
        End If
 
        Debug.Print "lg = " & Len(strFolderName) & " parent : " & oFile.ParentFolder.Path & ", mid : " & Mid(oFile.ParentFolder.Path, Len(strFolderName))
        With wksDest
          .Cells(iRow, 1) = Mid(oFile.ParentFolder.Path, lgRepParent + 1)          
          .Cells(iRow, 2) = oFile.Name
          .Cells(iRow, 3) = Round(oFile.Size / 1024, 0) ', "### ### ##0") 'conversion en ko
          .Cells(iRow, 4) = DateSerial(annee, mois, jour)
          .Cells(iRow, 5) = dateTime
          .Cells(iRow, 6) = dateTimeDiff
          '.Cells(iRow, 6) = oFile.DateCreated
          '.Cells(iRow, 7) = oFile.DateLastModified
          '.Cells(iRow, 8) = oFile.DateLastAccessed
        End With
    iRow = iRow + 1
    dateTimePrev = dateTime
    parentFolderPrev = oFile.ParentFolder.Path
 
    End If
  Next oFile
 
 
  'For Each oSubFolder In oSourceFolder.SubFolders
    ' On peut mettre ici un traitement spécifique pour les dossiers
  'Next oSubFolder
 
  If bIncludeSubfolders Then
    For Each oSubFolder In oSourceFolder.SubFolders
        ListFilesInFolder oSubFolder.Path, True, lgRepParent
    Next oSubFolder
  End If
  'Range("A:A").EntireColumn.Hidden = True
 
End Sub

20/12/2016, 19h20
l_autodidacte

Peut-être un peu ce genre de code , mais à adapter !

Tu m'excusera, la longueur du code de Browser4Folder m'a un peu découragé. Du coup, je suis allé faire des recherches et je suis tombé sur ce post : ici

Je l'ai adapté pour avoir écrire dans un fichier txt et avoir la liste des fichier au lieu des répertoires.

J'ai pas mal avancé

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
 
Option Explicit
 
'Const outFile = "file.html"
Const outFile = "toto.txt"
 
Dim oFiletxt,Path,Ws,SourceImgFolder,StartTime,MsgTitre,DurationTime,objFolder,CheminDossier,Dossier,Copyright
Dim intSize,objShell,fso,strSize
Copyright = "© Hackoo © 2013"
 
MsgTitre = "Générer une arborescence d'un dossier en HTML "&Copyright&""
Set objShell = CreateObject("Shell.Application")
'Set objFolder = objShell.BrowseForFolder(0, "Veuillez choisir un dossier "&Copyright, 1, "c:\Programs")
'If objFolder Is Nothing Then WScript.Quit
 
'CheminDossier = objFolder.self.path
CheminDossier = "C:\Users\winSevenEn\Documents\test_list"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(CheminDossier)
intSize = Dossier.Size
If intSize = 0 Then
	MsgBox "Le Dossier " & CheminDossier & " est vide",16,"Dossier Vide"
	WScript.Quit
End if
MsgBox "Le Dossier " & CheminDossier & " est vide",16,"Dossier Vide"
 
intSize = Round(FormatNumber(intSize)/(1024),2)
If intSize < 1024 Then 
	strSize = intSize & " Ko"
elseif intSize < 1048576 Then 
	strSize = Round(FormatNumber(intSize)/(1024),2)& " Mo"
else
	strSize = Round(FormatNumber(intSize)/(1073741824),2) & " Go"
end If
 
Set oFiletxt = fso.CreateTextFile(outFile,True)
Set Ws = CreateObject("Wscript.Shell")
 
 
StartTime = Timer 'Début du Compteur Timer
'oFiletxt.WriteLine "+ <img src="&SourceImgFolder&">  <a target=_Blank href='file:///" & _
	'CheminDossier & "'>" & CheminDossier & "</a><font color=""Yellow"">&nbsp;&nbsp;["&strSize&"]</font><br><br>" & _
	'List(CheminDossier, CheminDossier) '& "</body></hmtl>"
	List(CheminDossier)
oFiletxt.Close
 
DurationTime = FormatNumber(Timer - StartTime, 0) & " secondes." 'La durée de l'exécution du script
Ws.Popup "La génération au format HTML est terminée en "& DurationTime & " !","5",MsgTitre,64
Ws.Run outFile
 
 Function List(directory)
'Function List(directory, directoryInputUser)
	Dim objFso,objRootFolder,subfolders,objFile,objFolder,subfiles,NBFiles,intSize
	On Error Resume next
	Set objFso = CreateObject("Scripting.FileSystemObject")
	Set objRootFolder = objFso.GetFolder(directory)
	Set subfolders = objRootFolder.SubFolders
	Set subfiles = objRootFolder.Files
 
	NBFiles = 0
	For each objFile in subfiles
		NBFiles = NBFiles + 1
		intSize = Round(FormatNumber(objFile.Size)/(1024),2)
 
		oFiletxt.WriteLine(Mid(objFile.Path, Len("C:\Users\winSevenEn\Documents\test_list")+2) & ";" & objFile.Name & ";" & intSize)
		'oFiletxt.WriteLine(objFile.Name)
	Next
 
	For each objFolder in subfolders		
		List objFolder 'Appel récusive de la fonction List
		'List objFolder, directoryInputUser 'Appel récusive de la fonction List
		'oFiletxt.WriteLine("</DL>")
	Next    
End Function

Il me restera :
- à parser mes fichiers pour récupérer la date dans le nom
- calculer le temps entre chaque fichier

chose que je ne comprends pas, c'est que je n'arrive pas à faire passer 2 arguments. J'ai le message d'erreur m'indiquant que je n'ai pas le droit d'invoquer la procédure avec des parenthèses.

Quand une procédure est déclaré avec un seul paramètre, elle peut être appeller avec des parenthèse comme tout language ( exemple toto(param) )
Quand une procédure est déclaré avec deux paramètre (au moins, j'ai pas testé plus), elle NE peut PAS être appeller avec des parenthèse comme tout language ( exemple toto(param, param2) )
Bon sinon je suis content, j'ai pas mal avancé, je pense que ce sera beaucoup plus efficace que via VBA.

Si la date recherchée est celle de la création, de modification ou du dernier accès au fichier, il est possible de la trouver.
Par contre, je n'ai pas bien compris ce que tu veux dire par "calculer le temps entre chaque fichier".

J'ai modifié un peu le script (et que hackoofr ne m'en veuille pas, j'ai quand même laissé son Copyright) en introduisant une fonction de formatage de la taille des fichiers pour obtenir ce

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
 ' Copyright = "© Hackoo © 2013"
Option Explicit
 
Const outFile = "toto.txt"
 
Dim oFiletxt,Ws, objFolder,CheminDossier, Dossier, TotalSize, NBFiles
Dim intSize,objShell,fso,strSize
'======================
Set ShApp = CreateObject("Shell.Application")
    Const BIF_RETURNONLYFSDIRS = 1
    Dim DialogTitle, Item, ShApp
    DialogTitle = "Sélection de dossier(s) : (Pas de : Bureau, Poste de Travail, Favoris réseau et/ou ses sous-éléments)"
    Set Item = ShApp.BrowseForFolder(0, DialogTitle, BIF_RETURNONLYFSDIRS, "")
    If Item Is Nothing Then WScript.Quit 0
    CheminDossier = Item.ParentFolder.ParseName(Item.Title).Path
Set ShApp = Nothing
'======================
NBFiles = 0
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(CheminDossier)
intSize = Dossier.Size
 
If intSize = 0 Then
    MsgBox "Le Dossier " & CheminDossier & " est vide",16,"Dossier Vide"
    WScript.Quit
End if
TotalSize = FormatSize(intSize)
 
Set oFiletxt = fso.CreateTextFile(outFile,True)
Set Ws = CreateObject("Wscript.Shell")
List CheminDossier
oFiletxt.WriteLine vbNewLine & "Taille totale du dossier : " & TotalSize & " (dans " & NBFiles & " fichiers)"
Ws.Run outFile
'=========================
 Function List(directory)
    Const L = 45
    Dim objFso, objRootFolder, osubfolders, objFile, objFolder, subfiles, intSize
    'On Error Resume next  ' ### cette instruction masque toujours les erreurs, donc à EVITER tant que possible
    ' J'ai exprès mis la ligne précédente en commentaire pour voir s'il y a des erreurs pendant
    ' l'exécution et il y en a : Argument ou appel de procédure incorrect : 'String'.
    ' Elle se produit lorsque la longueur du chemin au fichier dépasse la valeur de L.
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objRootFolder = objFso.GetFolder(directory)
    Set osubfolders = objRootFolder.SubFolders
    Set subfiles = objRootFolder.Files
 
 
    For each objFile in subfiles
        NBFiles = NBFiles + 1
        intSize = FormatSize(objFile.Size)
        ' Formatage du texte de sortie pour une meilleure lisibilité
        ' Ligne où se produit l'erreur. Pour l'éviter, on doit augmenter la valeur de la constante L plus haut
         oFiletxt.WriteLine objFile.Path & String(L - Len(objFile.Path), " ") & "  Taille : " & intSize & String(18 - Len(intSize), " ") & " Créé : " & objFile.DateCreated
    Next
 
    For each objFolder in osubfolders        
        List objFolder 
    Next    
End Function
'======================
Function FormatSize(iSize)
   Dim Units, I
   Units = Array(" Bytes", " KB", " MB", " GB", " TB", " PB", " EB", " ZB", " YB")
   For I = 0 To 8
       If iSize > 1024 Then
           iSize = iSize / 1024
       Else
           Exit For
       End If
   Next
   ' 10 tient compte du séparateur décimal et des 2 chiffres après ce séparateur.
   FormatSize = Right("0000000000" & FormatNumber(iSize, 2) , 10) & Units(I)
End Function

En espérant qu'il sera à ton goût.

21/12/2016, 12h49
weed

1 pièce(s) jointe(s)

En fait, le but de ce petit script est d'avoir une vision globale de la volumétrie des fichiers recus dans chaque répertoires. J'ai de la chance, je n'ai pas vraiment de gros besoin un simple fichier CSV suffit pour le moment.
Ce fichier CSV sera convertis en Excel pour y faire des tableaux croisées dynamiques. Je pourrais faire facilement des agrégats par jours, également par heures. Ainsi, on pourra y apprendre les pics d'activités, deviner les plages horaires, le nombre de fichiers. ... Cela permettra ainsi de pouvoir faire des prévisions pour compléter des documents. J'avais donc justement fais exprès de supprimer la conversion sur d'autres unité parce que ces données sont amenés à être retravaillés.

Pour les écarts, enfin de compte, pour le moment ce n'est pas très pertinent et il ne faut pas trop que je perde de temps la dessus. Je verrais cela un peu plus tard quand j'aurais le temps en tache de fond.

Sinon pour info, les images valent mieux qu'un long discours comme on dit. Voila, ce que j'obtenais lorsque je lançais ma macro VBA :
Pièce jointe 229726

L'écart journalier correspond à la date du précédant fichier - la date du fichier courant par jour. Comme les fichiers sont recu sur des plages, il est inutile de calculer l'écart entre le dernier fichier de la veille et le premier fichier du jour (fichier courant). Dans ce cas précis, en G11 par exemple, j'avais mis à vide.

Souvent en entreprises, les fichiers sont horodatés qui correspond à une date beaucoup plus fiable que la date système, il faudra donc je la parse.

Voilou pour les infos.
Je vais me repencher sur le sujet un peu plus tard.

Pour rechercher la date et l'heure à partir du nom du fichier, j'ai ajouté une fonction qui le fait.
Le script retouché ressemblerait à ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
  ' Copyright = "© Hackoo © 2013"
Option Explicit
 
Const outFile = "toto.txt"
 
Dim oFiletxt,Ws, objFolder,CheminDossier, Dossier,  NBFiles
Dim intSize,objShell,fso,strSize
'======================
Set ShApp = CreateObject("Shell.Application")
    Const BIF_RETURNONLYFSDIRS = 1
    Dim DialogTitle, Item, ShApp
    DialogTitle = "Sélection de dossier(s) : (Pas de : Bureau, Poste de Travail, Favoris réseau et/ou ses sous-éléments)"
    Set Item = ShApp.BrowseForFolder(0, DialogTitle, BIF_RETURNONLYFSDIRS, "")
    If Item Is Nothing Then WScript.Quit 0
    CheminDossier = Item.ParentFolder.ParseName(Item.Title).Path
Set ShApp = Nothing
'======================
NBFiles = 0
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(CheminDossier)
intSize = Dossier.Size
 
If intSize = 0 Then
    MsgBox "Le Dossier " & CheminDossier & " est vide",16,"Dossier Vide"
    WScript.Quit
End if
'TotalSize = FormatSize(intSize)
 
Set oFiletxt = fso.CreateTextFile(outFile,True)
Set Ws = CreateObject("Wscript.Shell")
List CheminDossier
 
Ws.Run outFile
'=========================
 Function List(directory)
 
    Dim objFso, objRootFolder, osubfolders, objFile, objFolder, subfiles, intSize
    'On Error Resume next  
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objRootFolder = objFso.GetFolder(directory)
    Set osubfolders = objRootFolder.SubFolders
    Set subfiles = objRootFolder.Files
 
    For each objFile in subfiles
        If LCase(objFso.GetExtensionName(objFile.Name)) = "xml" Then
        NBFiles = NBFiles + 1
        intSize = FormatSize(objFile.Size)
         oFiletxt.WriteLine objFile.Path &  "    Taille : " & intSize  & "   Date : " & GetDateTimeFromFileName(objFile.Name)
        End If
    Next
 
    For each objFolder in osubfolders        
        List objFolder 
    Next    
End Function
'======================
Function FormatSize(iSize)
   Dim Units, I
   Units = Array(" Bytes", " KB", " MB", " GB", " TB", " PB", " EB", " ZB", " YB")
   For I = 0 To 8
       If iSize > 1024 Then
           iSize = iSize / 1024
       Else
           Exit For
       End If
   Next
   ' 10 tient compte du séparateur décimal et des 2 chiffres après ce séparateur.
   FormatSize = Right("0000000000" & FormatNumber(iSize, 2) , 10) & Units(I)
End Function
'===================
Function GetDateTimeFromFileName(sFileName)
    Dim Jour, mois, annee, hr, mn, sec, MaDate
 
    MaDate = Split(sFileName, "_")(3) ' 3 est la position de la date dans le nom du fichier; la première position étant zéro
    Jour = Mid(Madate, 9, 2)
    Mois = Mid(MaDate, 6, 2)
    Annee = Left(MaDate, 4)
    hr = Mid(MaDate, 12, 2)
    mn = Mid(MaDate, 14 ,2)
    sec = Right(MaDate,2)
    GetDateTimeFromFileName = Jour  & "/" & Mois & "/" & annee & " " & hr & ":" & mn & ":" & sec
End Function

A toi d'en juger et de modifier selon ton besoin

24/12/2016, 13h03
Marc-L

Bonjour !

Citation:

Envoyé par weed

Le script en VBA fonctionne bien si les répertoires ne sont pas trop chargé en fichiers. Je suis limite obligé de lancer mon script le soir pour laisser tourner tranquillement Excel, sinon il se met à rapidement planter.

Je pensais donc peut être qu'en lancant un fichier *.vbs dans une console et qui écrirait dans un fichier Excel fermé serait peut être mieux. Je pourrais faire d'autres chose sur mon poste.

Sachant que sans cache la fonction Dir VBA peut s'avérer être deux fois plus rapide que FSO
et si c'est dans le cache le facteur peut monter à sept en faveur de Dir ! …

Un scan complet de la partition système *.dl* sans cache et fichier d'échange vidé prend par exemple de mon côté
avec Dir VBA 157 secondes (i5 2.5GHz disque dur non SSD) et avec cache 35 secondes,
affichage dans Excel compris de plus de 42 200 fichiers …
Pas de souci non plus en affichant tous les fichiers de la partition … Et via les API Windows c'est encore plus rapide !

Voir les exemples dans les sous-forums Contribuez et VBA du forum Excel ainsi dans les téléchargements le classeur de kiki29 (API) …

S'il y a plantage, le code est donc en question (certainement un oubli de gestion d'erreur des cas particuliers) :
il serait judicieux de connaître l'erreur affichée ainsi que la ligne de code la déclenchant
le tout accompagné du code utilisé, pas ici mais dans le sous-forum VBA d'Excel bien entendu …

_________________________________________________________________________________________________________
Je suis Paris, Berlin, Nice, Bruxelles, Charlie, …