Voir aussi
Taille d'un répertoire
Est-il possible en VBA de mesurer et renvoyer la taille d'un répertoire donné?
Sub TailleUnRépertoire()

Dim Fso As Object, A As Double
Dim File As Object, Répertoire As String

Répertoire = "C:\Excel"

Set Fso = CreateObject("Scripting.FileSystemObject")
Set File = Fso.GetFolder(Répertoire)
A = File.Size

MsgBox "Taille du répertoire " & File & " : " & A

End Sub
Denis Michon,
Ajouté ou modifié le 30/05/2004 (N°1432)
Répertoire vide ou inexistant ?
Je cherche à tester l'existence d'un répertoire.j'utilise la fonction DIR. Ca fonctionne très bien pour un fichier, mais dans le cas d'un répertoire, il me retourne "vide" si le répertoire n'existe pas, ou s'il existe, mais qu'il est vide. Comment faire la différence ?
Faute de mieux, tu peux passer par exemple par la fonction GetAttr :

Function
RépertoireExiste(Chemin As String) As Boolean
On Error Resume Next
RépertoireExiste = GetAttr(Chemin) And vbDirectory
End Function

Sub Test()
MsgBox RépertoireExiste("C:Truc")
End Sub
Laurent Longre, (N°1264)
Tester l'existence d'un répertoire et le créer
Je voudrais sauver par VBA un fichier dans un dossier. Mais j'aimerais avant tester si le dossier dans lequel je voudrais enregistrer mon fichier existe déjà. Si ce n'est pas le cas je voudrais créer ce dossier. Quelle méthode employer ?
Sub SaveInMyFolder()
Dim x As String, strPath As String
On Error
Resume Next
strPath = "c:\mesdocuments\mondossier\"
x =
GetAttr(strPath) And 0
If Err <> 0 Then
MkDir strPath
End If

ActiveWorkbook.SaveAs FileName:=strPath & "" & ActiveWorkbook.Name
End Sub

Adapté et traduit de
Vasant Nanavati, John Walkenbach, (N°1263)
Suppression de répertoires
Comment supprimer depuis excel des répertoires avec leurs sous répertoires et tous les fichiers qu'ils contiennent ?
Sub SupprDossier()
'supprimer des dossiers avec tout ce qu'ils contiennent
'(y compris leurs sous-dossiers et leur contenu)
Dim fso As Object, Dossier$

Set fso = CreateObject("Scripting.FileSystemObject")
Dossier = "D:00Mes Docs Excel2"
fso.DeleteFolder Dossier

End Sub 'fs
Frédéric Sigonneau,
Ajouté ou modifié le 25/10/2003 (N°1262)
Créer des répertoires et sous répertoires
Par le code suivant MkDir "c: oto\" ou MkDir "c: oto" je crée le repertoire toto mais quel est le code pour créer "c: oto iti utu\";
Avec Excel 2000, tu peux utiliser la fonction Split, et donc la fonction personnalisée
ci-dessous. Elle crée un répertoire et tous ses répertoires parents s'ils n'existent pas.
Elle
peut aussi ajouter un ou des répertoires à un répertoire existant.

'========dans un module standard
'crée un répertoire et ses répertoires parents s'ils n'existent pas
'si aucun lecteur n'est précisé, la création est tentée dans le
'lecteur courant
'renvoie Vrai si l'opération réussit, Faux si elle échoue

Function MakeDirEx(DirPath$) As Boolean
Dim i%, tmp, Arr

If InStr(1, DirPath, ":") = 0 Then
Arr = Split(CurDir & DirPath, "\")
Else: Arr = Split(DirPath, "\")
End If

tmp = Arr(0)
For i = LBound(Arr) + 1 To UBound(Arr)
If Arr(i) <> "" Then
tmp = tmp & "\" & Arr(i)
On Error Resume Next
MkDir tmp
On Error GoTo 0
End If
Next

If Dir(DirPath, vbDirectory) = "" Then
On Error Resume Next
RmDir Arr(0) & "\" & Arr(1)
On Error GoTo 0
Else
MakeDirEx = True
End If

End Function 'fs

Sub test()
dossier$ = "dossier1\dossier2\dossier3"
MsgBox MakeDirEx(dossier)
dossier = "dossier1\dossier2\dossier4"
MsgBox MakeDirEx(dossier)
End Sub
Frédéric Sigonneau,
Ajouté ou modifié le 04/03/2005 (N°1261)
Déléter des répertoires vides
Dans un dossiers C:/transfert je reçois des dossiers qui peuvent être vides. Comment les éliminer si c'est le cas ?
A mettre dans un module standard :

Sub test()
SupprDossierSiVide "c:transfert"
End Sub

Sub SupprDossierSiVide(NomDossier$)'fs
'examiner un dossier et ses sous dossiers pour
'supprimer ceux qui sont vides
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(NomDossier)

'examen du dossier courant
For Each Flder In Dossier.subfolders
If Flder.subfolders.Count + Flder.Files.Count = 0 Then
fso.deletefolder Flder.Path
End If
Next

'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
SupprDossierSiVide sousRep.Path
Next sousRep
Set fso = Nothing

End Sub
Frédéric Sigonneau, (N°1260)
Nombre de fichiers d'un répertoire
Pour numéroter des classeurs avec un nom de dossier suivi d'un N°, j'aurais besoin de connaître le nombre de fichiers d'un répertoire....
Ci-dessous, deux procédures pour compter l'une le nombre de fichiers d'un
dossier et l'autre le nombre de sous-dossiers d'un dossier. Les deux procédures peuvent, en option,
examiner également l'ensemble de l'arborescence dépendant du dossier fourni en paramètre.


'compte le nombre de fichiers d'un lecteur
'(complet et assez rapide)

Sub test()
Dim Nb&
'nombre de fichiers à la racine du lecteur C
NbDeFichiers "c:\", Nb&, False
MsgBox Nb: Nb = 0
'nombre total de fichiers sur le lecteur C
NbDeFichiers "c:\", Nb&
MsgBox Nb: Nb = 0
'nombre de dossiers à la racine du lecteur C
NbDeDossiers "c:\", Nb&, False
MsgBox Nb: Nb = 0
'nombre total de dossiers sur le lecteur C
NbDeDossiers "c:\", Nb&
MsgBox Nb
End Sub

Sub NbDeFichiers(LeDossier$, Cpte&, Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
Cpte = Cpte + Dossier.Files.Count
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeFichiers sousRep.Path, Cpte
Next sousRep
End If
Set fso = Nothing
End Sub 'fs

Sub NbDeDossiers(DossierRacine$, Cpte&, Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(DossierRacine)
Cpte = Cpte + Dossier.SubFolders.Count
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeDossiers sousRep.Path, Cpte
Next sousRep
End If
Set fso = Nothing
End Sub 'fs
Frédéric Sigonneau, (N°1258)
Lister les caractéristiques des fichiers d'un répertoire
Peut-on faire pour lister dans un répertoire toutes les caractérisques des fichiers (dates, taille, extension...)
Ce code, à placer dans un module standard te permet de faire ce que tu souhaites :
Tu peux également télécharger un classeur exemple.

Option Explicit

Sub TousFichiersDunDossier()
Dim FSO As Object, Dossier As Object, NomDossier
Dim Files As Object, File As Object, i As Integer
Dim Sh As Worksheet
Dim EnTetes, ArrFSO

Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
'adapter le dossier racine si besoin
NomDossier = ChoixDossierFichier("")
If NomDossier = "" Then Exit Sub
Set Dossier = FSO.GetFolder(NomDossier)

Set Files = Dossier.Files
If Files.Count <> 0 Then
Set Sh = Sheets.Add
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
'mise en forme
With ActiveSheet.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
i = 1
For Each File In Files
i = i + 1
With File
ArrFSO = Array(.ParentFolder & "\", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(i, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(i, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
Next
End If
Sh.UsedRange.EntireColumn.AutoFit
Set FSO = Nothing: Set Sh = Nothing
Set Dossier = Nothing: Set File = Nothing
End Sub

Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function

Function ChoixDossierFichier(Racine, Optional SelType As Byte = 0)
Dim objShell, objFolder, Chemin, SecuriteSlash, FlagChoix&, Msg$

If SelType = 0 Then
FlagChoix = &H1&: Msg = "Choisissez un dossier :"
Else
FlagChoix = &H4000&: Msg = "Choisissez un fichier :"
End If

Set objShell = CreateObject("Shell.Application")
'le troisième paramètre permet de choisir
'la sélection d'un dossier ou d'un fichier (0 ou 1)
'le dernier paramètre permet de choisir le dossier racine
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, FlagChoix, Racine)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
Chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
Chemin = ""
End If

SecuriteSlash = InStr(objFolder.Title, ":")

If SecuriteSlash > 0 Then
Chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoixDossierFichier = Chemin
End Function
Frédéric Sigonneau, (N°1251)