VBA Un exemple utile FSO (fileSystemObject)

[Jean Luc Ravenne]

' Ecrire dans une table access (créée en amont et située dans le rep en cours) la liste des fichiers d'un rep, d'un disque, avec une extension precise ou pour tous fichiers)
Ce programme est applicable et transférable facilement..(il est écrit ici en VBA Access)
Seul le nom du dossier de base ("C:\"..etc) et l'extension sont passés en paramètres..

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
 
' ecrire dans la table T_FICHIERS de la base Documentation.mdb (rep en cours) la liste des fichiers correspondant a l'extension ou
' tous les fichiers si le parametre passé est *
 
Sub EcrireDansTableFichiersParExtension(ByVal Mondossier as string, ByVal MonExtension as string) 
    Dim ObjFSO, ListRepertoires, ListSousRep, ListFichiers, MonRep,  MonFich
    Set ObjFSO = CreateObject("Scripting.FileSystemObject")
    Set ListRepertoires = ObjFSO.GetFolder(Mondossier)
    Set ListSousRep = ListRepertoires.SubFolders
 
    ' Acceder a la base Documentation.mdb
    Dim MaBase As Database
    Set MaBase = OpenDatabase(CurrentProject.path & "\Documentation.mdb")
    Dim MonSql As String
    Dim MonNouveauFichier As String
    Dim MaNouvelleExtension As String
    Dim MonNewChemin As String
    Dim MonNouveauDossier As String
    MonSql = ""
 
    For Each MonRep In ListSousRep
            Set ListFichiers = MonRep.Files
            For Each MonFich In ListFichiers
                ' tester l'extension
                If Right(MonFich.Name, 3) = MonExtension Or MonExtension = "*" Then
 
                    'Remplacer nom de fichier si le nom de fichier contient une ' (apostrophe)
                    ' ideml pour extension
                    ' idem pour rep
                    MonNouveauFichier = Replace(MonFich.Name, "'", " ")
                    MaNouvelleExtension = Replace(MonFich.Type, "'", " ")
                    MonNouveauDossier = Replace(MonRep.Name, "'", " ")
                    MonNewChemin = Replace(MonRep.path, "'", " ")
 
 
                    'Ecrire dans la base Documentation.mdb
                    MonSql = "insert into T_FICHIER VALUES ('" & MonNewChemin & "','" & MonNouveauFichier & "','" & MaNouvelleExtension & "','" & MonFich.DateLastModified & "','N')"
                    MaBase.Execute MonSql
                End If
            Next
        ' Appel d'une sous procedure RECURSIVE
        ' on s'appelle soi même !!!!!!
        ' pour lister l'ensemble des sous sous sous rep...
 
        Call EcrireDansTableFichiersParExtension(MonRep, MonExtension)
 
    Next
    Set MaBase = Nothing
 
End Sub

et la sous sub qui l'exécute :

Code :

1
2
3
4
5
6
7
8
9
 
Sub TesterSousProcedures()
Dim TimeDebut As Date
Dim TimeFin As Date
TimeDebut = Time
Call EcrireDansTableFichiersParExtension("G:\", "*")
TimeFin = Time
MsgBox "temps passé : " & Format(TimeFin - TimeDebut, "hh:mm:ss")
End Sub