Discussion :

[juju05]

Bonjour,

Je souhaite supprimer l'ensemble des fichiers enregistrés depuis 3 ans ou plus situés sous un ou plusieurs répertoires en me positionnant sur un répertoire situé beaucoup plus haut dans l'arborescence. Je ne connais pas le niveau de profondeur de l'arborescence.

Cela est-il réalisable par macro. vba excel ?

Merci d'avance.

[joe.levrai]

Bonjour,

voici qui devrait te donner les pistes : http://excel.developpez.com/faq/?pag...TriFichiersRep

au lieu de les trier, tu veux les supprimer, la différence est là
il faudra également parcourir les sous-répertoires ... en récursif je pense.

[juju05]

Merci beaucoup.

Comment balayer les répertoires en récursif ?

[joe.levrai]

Voici un exemple pour bien comprendre

ici, on va balayer l'ensemble des dossiers et sous dossiers du répertoire, jusqu'à atteindre la profondeur la plus basse
pour chaque dossier, sous-dossier, sous-sous-dossiers etc.... on écrit dans Excel son chemin d'accès

à toi d'adapter, tu as maintenant tout ce qu'il faut

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub RecursionSurDossiers(Repertoire As String, Num As Long)
'Num permet d'identifier la ligne dans Excel où on va écrire le chemin menant au dossier
'si Num = 0, on commencera à écrire dès la ligne 1
 
     Dim fso As Object
     Dim Dossier As Object
     Dim SousDossier As Object
 
     Set fso = CreateObject("Scripting.FileSystemObject")
 
     ' on se place sur le répertoire
     Set Dossier = fso.GetFolder(Repertoire)
 
     'pour chaque sous dossier du repertoire
     For Each SousDossier In Dossier.subfolders
 
        ' si le sous dossier contient lui même des dossiers
        If SousDossier.subfolders.Count > 0 Then
            ' la procédure s'appelle elle-même avec le sous-dossier en argument
            ' afin de descendre tout en bas de ton arborescence
            RecursionSurDossiers SousDossier.Path, Num
        End If
 
        ' une fois qu'on a fini toute l'arborescence des dossiers dans le sous-dossiers
        ' on remplie les données du sous-dossier lui-même
        Num = Num + 1
        Cells(Num, 1).Value = SousDossier.Path
 
     ' et on passe au suivant
     Next SousDossier
 
     Set fso = Nothing
 End Sub

et pour appeler la procédure, exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub EcrisMesDossiers()
    RecursionSurDossiers "C:\toto\etc..", 0
End Sub

[juju05]

Merci beaucoup.

La demande de mon utilisateur se précise. Comment savoir si un répertoire contient au-moins un fichier pdf et les balayer ?

[Invité]

Bonjour,
voila ce que j'avais fait dans un fichier vbs:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
Option Explicit
' 							Déclaration de la class
'***************************************************************************************************************************
class ClsRep
'***************************************************************************************************************************
' 	Déclaration des Variables Local de la Class
'***************************************************************************************************************************
dim MesRep(),FSO,Name,Rep,SousRep,SubClsRep,IndexRep 
 
' 	Les deux fonctions ci dessous sont appelées respectivement à la création et à la suppression d'une instance de class
'***************************************************************************************************************************
 
	Private Sub Class_Initialize()
		Set FSO = CreateObject("Scripting.FileSystemObject")
		IndexRep = 0
		redim MesRep(IndexRep)
 
	End Sub
 
	Private Sub Class_Terminate()
	dim I
	set FSO=nothing : set Rep= nothing
	for I= 1 to  IndexRep 
		set MesRep(I)=nothing
	next
 
	End Sub
'***************************************************************************************************************************
' 	Vérifie  si le répertoire passé en paramètre existe.
'	Vérifie si il existe des sous répertoires.
'	Craie de nouvelle instance  de la class si 1 ou plusieurs sous répertoires.
'***************************************************************************************************************************
 
     public sub ScanRep(RepRacine)
	 Name=RepRacine
	If FSO.FolderExists(RepRacine) Then
		 Set Rep= FSO.GetFolder(RepRacine)
		 For Each SousRep In Rep.SubFolders
			IndexRep = IndexRep + 1
			redim Preserve MesRep(IndexRep)  	'Tableau de sous répertoires.
			set SubClsRep=new ClsRep 			
			set MesRep(IndexRep)=SubClsRep
			set SubClsRep=nothing
			MesRep(IndexRep).ScanRep SousRep.path	'Effectue un scanne du sous répertoire détecté.
        	Next 
 
	end if
 
     end sub
'***************************************************************************************************************************
' 	Si je suis sous la racine du répertoire appelant, je ne Kill que les Fichiers
'***************************************************************************************************************************
 
     Public Sub KillRacine(NbJours,LaDate,Extensions,IsNotDelSousRep)
	dim I
	If FSO.FolderExists(Name) Then
	 	TestFile NbJours,LaDate	,Extensions	'Appel du sous programme qui supprime les fichiers. 
		for I = 1 to IndexRep				'Scanne le tableau des sous répertoires exécute KillSousRep.
			if IsNotDelSousRep=false then
				MesRep(I).KillSousRep NbJours,LaDate,Extensions
			else
				MesRep(I).KillRacine NbJours,LaDate,Extensions,IsNotDelSousRep
			end if	
 
        next
	end if
     end Sub
'***************************************************************************************************************************
' 	Je Kill les fichiers ainsi que les sous répertoires vides
'***************************************************************************************************************************
 
     Public Sub KillSousRep(NbJours,LaDate,Extensions)
	dim I
	If FSO.FolderExists(Name) Then
		TestFile NbJours,LaDate,Extensions	'Appel du sous programme qui supprime les fichiers. 
		for I = 1 to IndexRep				'Scanne le tableau des sous répertoires exécute KillSousRep.
			MesRep(I).KillSousRep NbJours,LaDate
'			MesRep(I).KillRacine NbJours,LaDate	'Si je ne veux pas Killer les Sous Repertoire, je mets en commentaire la ligne du dessus?
								'je retir le commentaire de la ligne MesRep(I).KillRacine NbJours,LaDate
 
       	 	next
	end if
	if IsKillSousRep=true then
	       if  Rep.size=0 then				'Supprime le répertoire si il ne contient plus de fichier.
		      FSO.DeleteFolder name,True
	       end if
         endif
     end Sub	
	 private function ExtensionOk(Fichier ,Extensions)
	 dim I 
	 Dim Ext
		ExtensionOk=false
		i=0
 
		for i=1 to ubound(Extensions)		
			if ucase(FSO.GetExtensionName(Fichier.Path)) =ucase(Extensions(i)) then
				ExtensionOk=true
				exit function
			end	if
		next			
	 end function
'***************************************************************************************************************************
' 	Fonction de suppression des fichiers en fonction de la date et l’écart du nombre de jours
'***************************************************************************************************************************
     private Sub TestFile(NbJours,LaDate, Extensions)
       dim ListFichiers,MonFich
 
	Set ListFichiers = Rep.Files
	 For Each MonFich In ListFichiers		'Scanne les Fichiers.
 
 
		if datediff("d",MonFich.DateCreated ,  LaDate) > NbJours then
			if ubound(Extensions)>0 then
				if ExtensionOk(MonFich,Extensions)=true then
					FSO.DeleteFile MonFich.Path
			end if			
			else
				FSO.DeleteFile MonFich.Path
			end if	
		end if
 
	 next
 
     end sub 
'***************************************************************************************************************************	
end class
'***************************************************************************************************************************
' 							Fin de la Class
'***************************************************************************************************************************
class Cls_TRep
	public SetClsRep
	public NbJour 
	public LaDate
	public Rep 
	public Extensions() 
	public IsNotDelSousRep
        public IsKillSousRep
	Private Sub Class_Initialize()
		redim  Extensions(0)
		IsNotDelSousRep=false
	End Sub
 
	Private Sub Class_Terminate()
			set SetClsRep=nothing
	End Sub
 
	public sub ScanRep()
		SetClsRep.ScanRep Rep 
	end sub
 
	public sub KillRacine()
		SetClsRep.KillRacine NbJour ,LaDate,Extensions,IsNotDelSousRep
	end sub
 
	public sub RedimExtention(Nb)
	redim  Extensions(nb)
	end sub
 
end class 
 
 
'							Début du programme
'---------------------------------------------------------------------------------------------------------------------------
dim MesRep()					'Déclart varble de class Cls_TRep (Tableau des repertoire racine)
dim SetClsRep					'Déclart varble de class ClsRep (repertoire racine)
dim unCls_TRep
Dim I
I=1
redim preserve MesRep(i)						'Redimentionne le tableau	
set  unCls_TRep =new Cls_TRep 					'Craie une  instance de la class Cls_TRep
set  MesRep(i)=unCls_TRep
set unCls_TRep=nothing
 
 
set  MesRep(i).SetClsRep=new ClsRep			'Craie une  instance de la class ClsRep
 
MesRep(i).NbJour =60
MesRep(i).LaDate=now
MesRep(i).Rep ="C:\DURUPT"
 
 MesRep(i).RedimExtention(3) 				'Défini le nombre et le nom des extension à effacer si pas dextension alor tous effacer
	MesRep(i).Extensions(1) ="txt"
	MesRep(i).Extensions(2) ="XLS"
	MesRep(i).Extensions(3) ="CSV"
	MesRep(i).IsNotDelSousRep=true			'faut il garder les répertoirs?
	MesRep(i).IsKillSousRep=true                    'il faut supprimer les répertoires dont la taille égale 0 Octet
 
i=i+1
redim preserve MesRep(i)
 
set  unCls_TRep =new Cls_TRep
set  MesRep(i)=unCls_TRep
set unCls_TRep=nothing
 
 
set  MesRep(i).SetClsRep=new ClsRep
 
MesRep(i).NbJour =60
MesRep(i).LaDate=now
MesRep(i).Rep ="C:\DURUPT2"
 
for I=1 to ubound(MesRep)
	MesRep(I).ScanRep
	MesRep(I).KillRacine
next
 
for I=1 to ubound(MesRep)
	set MesRep(I)=nothing
next
'set SetClsRep =nothing
 
 
'set SetClsRep= new ClsRep	'Craie une  instance de la class ClsRep
'SetClsRep.ScanRep= "C:\DURUPT"	'Lance la recherche des répertoire et des sous repertoires
'SetClsRep.KillRacine 35,now 	'Lance le Processus de supression (écart de jours = 35) (date du jour = now)
'set SetClsRep=nothing		'Libère la mémoire de l’instance de la class ClsRep (repertoire racine)				
'---------------------------------------------------------------------------------------------------------------------------
'							Fin du programme

[juju05]

Je dois balayer tous les pdf contenus dans un repértoire et ses sous-répertoires, les chercher dans un autre répertoire.

Si je ne les trouve pas, je dois balayer tous les fichiers contenant le même nom que le pdf dans le répertoire dans lequel se trouve le pdf et soit les supprimer soit les extraire sur excel.

[joe.levrai]

Pour manipuler/tester des fichiers dans des répertoires : utiliser la fonction Dir()

voir ici pour des exemples et une explication : http://warin.developpez.com/access/fichiers/


tu peux intégrer ton utilisation de Dir dans ta procédure récursive qui parcours ton arborescence

bon maintenant, c'est à toi de bosser, j'ai fais ma part