Discussion :

[Nicko29]

Je cherche à supprimer des fichiers dans un dossier qui comporte des sous dossier les fichiers ( des bases access) qui n'ont pas été modifié depuis un certain nombre de jour.

J'ai trouver des codes en VBScript :

Effacer fichier/dossier de + de xjrs

Effaces fichier et dossier qui date de plus de 15Jr

Mais je ne sais pas les adapter en vba ..

quelqu'un aurait-il fait ce genre de chose , je n'ai rien trouvé dans la Faq en VBA.

Merci

[Invité]

Bonjour

Les deux codes que tu as utilisent la bibliothèque FSO.

Je te conseille la lecture de cet article : http://warin.developpez.com/access/fichiers/

Ainsi tu comprendras à quoi correspond ton code.

Starec

[Nicko29]

Merci Starec, je suis passé à coté de cet article.

J'ai bien compris pour les références, j'ai regardé la manière d'utiliser l'objet FileSystemObject.


néanmoins sur le code suivant j'ai une erreur ici :

Code :

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

1
2
3
'instantation du file system object (FSO)
 
Set FSO = CreateObject("Scripting.FileSystemObject")

"instruction incorrecte a l'intérieur d'une procédure"

code utilisé :

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
'declaration des variables
Dim folder
Dim Subfolder
Dim path
Dim FSO
 
'instantation du file system object (FSO)
 
Set FSO = CreateObject("Scripting.FileSystemObject")
 
'initialisation de la variable contenant le chemin du repertoire racine
path = "F:\testeffacement"
 
'appel de la fonction recurcive avec comme argument le chemin du repertoire
'racine
recurcive path
 
Function recurcive(chemin) 'fonction récurcive pour traiter tout l'arboresence
                           'des dossiers
 
Set folder = FSO.GetFolder(chemin)  'utilisation du FSO pour prendre le dossier
                                    'racine
Set Subfolder = folder.SubFolders   'definition de la varibale pour les S/dossiers
 
For Each A In Subfolder 'pour chaque dossier dans le sous dossier racine
        Set fic = A.Files 'definition de la variables toucher les fichier des dossier
 
        fichier fic 'appel de la fontion fixhier
        recurcive A 're-appel de la fonction recurcive pour traiter les S/dossiers
        dossier
Next
End Function 'fin de la fonction
 
 
Function fichier(fic) 'fonction qui traite les fichiers dans les dossiers A
 
For Each objfile In fic 'pour chaque fichier dans dossiers de fichier
        Set f = FSO.GetFile(objfile) 'utilisation du FSO pour prendre le fichier
            If DateDiff("D", objfile.DateLastModified, Now) > 10 Then 'si la derniére modification du fichier est plus ancienne que X jours
            MsgBox objfile & " a suprimer" 'alors effacer le fichier avec option de forcer pour les fichier en lecture seule
            'objFSO.DeleteFile f, force = yes
            End If 'fin du SI
    Next
 
End Function 'fin de la fonction
 
 
Function dossier() 'fonction pour supprimer les dossier vides (taille = 0 )
       Set folder = FSO.GetFolder(path) 'utilisation du FSO pour prendre le dossier
       For Each B In folder.SubFolders 'pour chaque dossier dans le dossier racine
                If B.Size = 0 Then 'si la taille du dossier est egal a 0 (donc vide)
                MsgBox B & B.Size 'effacer le dossier
                'objFSO.DeleteFolder subfolders, force = yes
                End If 'fin du SI
        Next
 
End Function 'fin de la fonction

Je comprend pas tout encore mais je me soigne pour çà .
Je vais tacher de trouver l'erreur.

[Jean-Philippe André]

bonjour,
vérifie que tu as bien pensé à ajouter les références pour les FSO.

[Nicko29]

J'ai bien ajouter la référence "Microsoft Scripting Runtime" pourtant

[francishop]

Bonsoir,

Egalement, je ne comprends pas tout mais il me semble qu'avec la bibliothèque d'objets microsoft scripting runtime dans les declaration des variables généralement on y voit quelque chose du genre :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
' Variables 'Scripting'
Dim fso As Scripting.FileSystemObject
Dim fld As Scripting.Folder
Dim fle As Scripting.File
 
' On y voit aussi vers la fin :
 
' Libération des objets
Set fle = Nothing
Set fld = Nothing
Set fso = Nothing

Cordialement.

[Nicko29]

Bon je galère toujours un peu, j'ai résolu les problèmes de références mais maintenant j'ai une erreur que je ne comprend pas.

J'appelle la fonction recursive (chemin) comme cela:

Code :

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

1
2
3
Private Sub Commande0_Click()
recurcive ("G:\SAUV\SauvBdd")
End Sub

La fonction :

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
Function recurcive(chemin) 'fonction récurcive pour traiter tout l'arboresence
                           'des dossiers
 
'declaration des variables
Dim folder 'As Scripting.folder
Dim Subfolder
Dim path 'As String
Dim FSO 'As Scripting.FileSystemObject
 
'instantation du file system object (FSO)
Set FSO = CreateObject("Scripting.FileSystemObject")
 
'initialisation de la variable contenant le chemin du repertoire racine
path = "G:\SAUV"
 
'appel de la fonction recurcive avec comme argument le chemin du repertoire
'racine
recurcive path
 
 
Set folder = FSO.GetFolder(chemin)  'utilisation du FSO pour prendre le dossier
                                    'racine
Set Subfolder = folder.SubFolders   'definition de la varibale pour les S/dossiers
 
For Each a In Subfolder 'pour chaque dossier dans le sous dossier racine
        Set fic = a.Files 'definition de la variables toucher les fichier des dossier
 
        fichier fic 'appel de la fontion fixhier
        recurcive a 're-appel de la fonction recurcive pour traiter les S/dossiers
        dossier
Next
End Function 'fin de la fonction
 
 
Function fichier(fic) 'fonction qui traite les fichiers dans les dossiers A
 
For Each objfile In fic 'pour chaque fichier dans dossiers de fichier
        Set f = FSO.GetFile(objfile) 'utilisation du FSO pour prendre le fichier
            If DateDiff("D", objfile.DateLastModified, Now) > 10 Then 'si la derniére modification du fichier est plus ancienne que X jours
            MsgBox objfile & " a suprimer" 'alors effacer le fichier avec option de forcer pour les fichier en lecture seule
            'objFSO.DeleteFile f, force = yes
            End If 'fin du SI
    Next
 
End Function 'fin de la fonction
 
 
Function dossier() 'fonction pour supprimer les dossier vides (taille = 0 )
       Set folder = FSO.GetFolder(path) 'utilisation du FSO pour prendre le dossier
       For Each b In folder.SubFolders 'pour chaque dossier dans le dossier racine
                If b.Size = 0 Then 'si la taille du dossier est egal a 0 (donc vide)
                MsgBox b & b.Size 'effacer le dossier
                'objFSO.DeleteFolder subfolders, force = yes
                End If 'fin du SI
        Next
 
End Function 'fin de la fonction

et j'ai cette erreur là :

Erreur d'exécution '28' , espace pile insuffisant

edit :l'erreur ce produit sur :

Code :

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

recurcive path

J'ai bien regarder dans l'aide d'access , mais je comprend pas , j'ai l'impression que le code tourne en boucle.
Une idée ?

[Nicko29]

bonsoir,

J'ai résolu et adapté mes problème de code

je le met si cela peut en aider certain :

la partie concernant la suppression des fichiers se trouve entre if et else

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
'declaration des variables
Dim folder As Scripting.folder
Dim Subfolder
Dim path As String
Dim Repsauv As String
Dim fso As Scripting.FileSystemObject 'FileSystemObject
Dim f As Scripting.File 'As Scripting.FileSystemObject
Dim fic, a, objfile
 
'instantation du file system object (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
'initialisation de la variable contenant le chemin du repertoire racine
Repsauv = DLookup("[Chemin]", "TCheminInstall", "[TypeChemin] = 'ChRepS'")
TestRep:
If fso.FolderExists(Repsauv) Then
 
        Set folder = fso.GetFolder(Repsauv)  'utilisation du FSO pour prendre le dossier
                                    'racine
        Set Subfolder = folder.SubFolders   'definition de la varibale pour les S/dossiers
        Set fic = folder.Files
        For Each a In Subfolder 'pour chaque dossier dans le sous dossier racine
                Set fic = a.Files 'definition de la variables toucher les fichiers des dossier
                For Each objfile In fic 'pour chaque fichier dans dossiers de fichier
                            Set f = fso.GetFile(objfile) 'utilisation du FSO pour prendre le fichier
                            If DateDiff("D", objfile.DateLastModified, Now) > 10 Then 'si la derniére modification du fichier est plus ancienne que X jours
                            fso.DeleteFile f, True 'alors effacer le fichier avec option de forcer pour les fichier en lecture seule
                            End If 'fin du SI
                Next
        Next
 Else
 MsgBox "Le répertoire n'existe pas," & vbCrLf & "cliquez sur ok pour commençer la procédure de séléction du répertoire ", vbExclamation, " Répertoire inexistant"
 Repsauv = SelectFolder("Sélectionnez le répertoire où sont situées les sauvegarde :", Application.hWndAccessApp)
        If Repsauv = "" Then
        Exit Function
        Else
        GoTo TestRep
        End If
End If