Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

[Banosjo]

Bonjour,

Si ça peut intéresser quelqu'un, j'ai enfin trouvé une méthode pour effacer le contenu d'un dossier, incluant les sous-dossiers jusqu'au 2e niveau, sans utiliser le Scripting.FileSystemObject (qui ne fonctionnait parfois pas sur certains postes de travail) :

Sub RemDos()
'
' Efface le contenu du dossier Temp_Courriel incluant les sous-dossiers jusqu'au 2e niveau
'
Dim XX As Byte
Dim YY As Byte
Dim XnbFichiers As Byte
Dim YnbFichiers As Byte
Dim XTableau() As String
Dim YTableau() As String
Dim XDirection As String
Dim YDirection As String
Dim ZDirection As String
Dim CheTemp As String
Dim Msgboxresult As Byte

On Error Resume Next

CheTemp = "C:\Temp_Courriel\"

' 1er niveau
XDirection = Dir(CheTemp & "*.*", vbDirectory)
Do While Len(XDirection) > 0
XnbFichiers = XnbFichiers + 1
ReDim Preserve XTableau(1 To XnbFichiers)
XTableau(XnbFichiers) = XDirection
XDirection = Dir()
Loop

If XnbFichiers > 0 Then

For XX = 1 To XnbFichiers
If XTableau(XX) <> "." And XTableau(XX) <> ".." Then
If Left(Right(XTableau(XX), 4), 1) <> "." Then

' 2e niveau
YnbFichiers = 0
YDirection = Dir(CheTemp & XTableau(XX) & "\*.*", vbDirectory)
Do While Len(YDirection) > 0
YnbFichiers = YnbFichiers + 1
ReDim Preserve YTableau(1 To YnbFichiers)
YTableau(YnbFichiers) = YDirection
YDirection = Dir()
Loop

If YnbFichiers > 0 Then

For YY = 1 To YnbFichiers
If YTableau(YY) <> "." And YTableau(YY) <> ".." Then
If Left(Right(YTableau(YY), 4), 1) <> "." Then

' 3e niveau
ZDirection = Dir(CheTemp & XTableau(XX) & "\" & YTableau(YY) & "\*.*", vbDirectory)
Do While Len(ZDirection) > 0
If ZDirection <> "." And ZDirection <> ".." Then
If Left(Right(ZDirection, 4), 1) <> "." Then

RmDir CheTemp & XTableau(XX) & "\" & YTableau(YY) & "\" & ZDirection
Else
Kill CheTemp & XTableau(XX) & "\" & YTableau(YY) & "\" & ZDirection
End If
End If
ZDirection = Dir()
Loop
RmDir CheTemp & XTableau(XX) & "\" & YTableau(YY)
Else
Kill CheTemp & XTableau(XX) & "\" & YTableau(YY)
End If

End If
Next YY
End If

RmDir CheTemp & XTableau(XX)
Else
Kill CheTemp & XTableau(XX)
End If

End If
Next XX
End If

If Err > 0 Then
      Msgboxresult = MsgBox("Le contenu de certains sous-dossiers du dossier temporaire Temp_Courriel" _
        & vbCr & "n'a pu être effacé automatiquement. Ne pas oublier de les effacer manuellement.", _
        vbExclamation + vbOKOnly, "Suppression automatique non-complétée...")
   Err.Clear
End If

End Sub

J'ai cherché longtemps cette solution sans succès et enfin ça fonctionne !!!

Bye !!

José

 

[Banosjo]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Besoin d'aide SVP ..

La macro fonctionne #1 mais je me rend compte que l'instruction KILL ne semble pas effacer les gros fichiers (j'essaye d'en effacer un de 5 Mo et j'ai une erreur) .. Y a-t-il une limite de grosseur de fichier qu'on peut effacer avec l'instruction KILL ??? J'ai beau chercher mais je ne trouve pas la réponse

Merci de me répondre !!

Jo

 

[Pierrot93]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Bonjour,

A ma connaissance pas de limite de grosseur... Par contre le fichier en question n'est il pas en cours d'utilisation ? et as tu toutes les permissions n"cessaires pour effectuer cette opération ?

bon après midi
@+

 

[Banosjo]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Le fichier n'est pas en cours d'utilisation et je peux le supprimer manuellement .. c'est vraiment bizarre ?

Précisions :

Après d'autres tests, il appert que le problème n'est pas au niveau de la grosseur des fichiers mais au format de ceux-ci. La macro efface tous les fichier avec une extension à 3 lettres (.doc, .xls, .pdf) mais l'instruction KILL n'est pas capable de supprimer les fichiers avec des extensions à 4 lettres (.xlsx, .pptx) .. Est-ce possible que l'instruction KILL soit limité aux extension à 3 lettres ?

Auriez-vous une solution à proposer ? Je pense peut-être à renommer l'extension avant de Killer .. d'autres idées ?

Merci !!

Jo

 

[david84]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Bonjour, Pierrot
au hasard, as tu testé ".xl*" ?
A+

 

[Pierrot93]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Re, bonjour David

pas de souci chez moi, instruction exécutée à partir d'excel 2003, me suprime bien un fichier "xlsm"....

 

[Banosjo]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Rebonjour,

Le problème est dans mon code finalement .. je viens de me rendre compte que j'ai mis des instructions comme

If Left(Right(XTableau(XX), 4), 1) <> "." Then

pour passer au niveau suivant de sous-dossier et c'est pour ça qu'il ne supprime pas les fichiers avec des extensions à 4 lettres

J'essaie en ce moment de corriger mon code pour inclure les extension à 4 lettres, du genre

If Left(Right(XTableau(XX), 4), 1) <> "." Then
If Left(Right(XTableau(XX), 5), 1) <> "." Then

mais bon, j'ai des soucis avec la suite (le autrour du "end if") .. je vais me pencher là-dessus (vos suggestions sont les bienvenues)

Merci pour vos réponses !!

Jo

 

[david84]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Re
au lieu de te servir de If Left(Right(XTableau(XX), 4), 1) <> "." Then... regarde du côté de l'utilisation de l'opérateur Like, du style If NomFichier Like "*.xls*" Then...
A+

 

[Banosjo]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Merci David de la suggestion, je vais regarder ça .. cependant, c'est que je veux effacer tous les types de fichiers, pas seulement les .xls ..

j'en apprend à tous les jours !!!

Jo

 

[david84]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Merci David de la suggestion, je vais regarder ça .. cependant, c'est que je veux effacer tous les types de fichiers, pas seulement les .xls ..

j'en apprend à tous les jours !!!

Jo

Alors, si l'on considère que tous tes fichiers possèdent l'extension minimale ".xl" (.xls, .xla, .xlsx, .xlsm,...), quelque chose du style If NomFichier Like "*.xl*" Then... (en faisant tout de même attention à ce que tes noms de fichiers que tu veux conserver ne comportent pas ".xl" (azer.xltyyui.text par exemple).
Après, il faut "caler" le motif du Like en fonction, même sans plus d'info...
A+

 

[Banosjo]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

En fait, comme je veux effacer tous les types de fichiers (des .pdf, .doc, etc.), je vais essayer

If NomFichier Like "*.*" Then

et je vous en reparle

Merci !

 

[david84]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

En fait, comme je veux effacer tous les types de fichiers (des .pdf, .doc, etc.), je vais essayer

If NomFichier Like "*.*" Then

et je vous en reparle

Merci !

Attention ! Si un fichier que tu veux conserver comporte un point dans son nom (Classeur.1.txt), ton motif l'éliminera, d'où ma précision dans mon précédent message.
A+

 

[david84]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Re
sinon, tu as aussi la possibilité d'utiliser InStrRev qui te permet de localiser le "." le plus à droite du nom complet de ton fichier, du style :

Sub NomFichier()
Dim extension As String
extension = Mid(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "."), Len(ThisWorkbook.FullName) - InStrRev(ThisWorkbook.FullName, ".") + 1)
MsgBox extension
End Sub

A+

 

[MJ13]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Bonjour à tous

Tibo m'avait donné cette formule pour extraire d'un nom de fichier l'extension par rapport au dernier point.

=STXT(LC(-2);TROUVE("//";SUBSTITUE(LC(-2);".";"//";NBCAR(LC(-2))-NBCAR(SUBSTITUE(LC(-2);".";""))))+1;99)

Cela doit être facilement transposable en VBA (remarque, cela doit faire comme le code de David ).

 

[david84]

Re : Effacer fichiers et sous-dossiers sans Scripting.FileSystemObject

Re Michel,
très bien cette formule (du grand Tibo) !
Placée dans une feuille de calcul, ma proposition VBA pourrait donner ceci :

Function Extension(c As String) As String
Extension = Mid(c, InStrRev(c, "."), Len(c) - InStrRev(c, ".") + 1)
End Function

A+