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 |
Partager