Récupérer le contenu d'un répertoire en VBA

Bonjour à tous,

Il y a plusieurs années, j'avais obtenu un programme bien pratique
permettant de récupérer en excel le contenu d'un répertoire.

Ceci est très pratique si vous voulez comparer 2 répertoires et repérer les
doublons (ou non doublons).

Voir ci-dessous le programme écrit en 2000 par B. Gérard pour MPFE.


Ma question : le programme s'arrête si les caractères du nom du fichier
récupéré sont en grec, russe ou autre langue.

Quelqu'un peut-il me dire comment modifier le fichier pour qu'il ne bloque
pas lorsqu'il rencontre des caractères spéciaux ?

Un tout grand merci par avance.

Fabian

Bonjour,

il semble que ce soit la fonction Dir qui pose problème sur les fichiers ou
répertoires en alphabet non romain.

J'ai supprimé ce Dir et l'ai remplacé par les méthodes SubFolder, Folders et
Files dans "Remplir" ci-dessous.
Ca semble bien fonctionner en testant sur l'alphabet cyrilique, et les noms
s'affichent bien en cyrilique également dans le tableau résultat.
NB : je n'ai pas changé le principe de l'algorithme (que j'aurais peut-être
écrit différemment).

Cordialement,
Jean-Claude



Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

ExtLocale = ExtFichier

Dim fs, f, f1, s, sf, n
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(RepertParent)
Set sf = f.Files
n = 0
For Each f1 In sf
If f1.Name Like ExtFichier Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = f1.Name
ActiveCell.Offset(1, -1).Select
n = n + 1
End If
Next
If n = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If

'Compter le nombre de sous-répertoires
Set sf = f.SubFolders
NbreRepert = sf.Count
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
For Each f1 In sf
LeDossierLocal(Compteur) = f1.Name
Compteur = Compteur + 1
Next
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
Call Remplir(ParentLocal, ExtLocale)
Next

'Redéfinir la largeur des colonnes
Columns("A:A").ColumnWidth = 85
Columns("B:B").ColumnWidth = 50

End Sub

Bonjour,

il semble que ce soit la fonction Dir qui pose problème sur les fichiers
ou répertoires en alphabet non romain.

J'ai supprimé ce Dir et l'ai remplacé par les méthodes SubFolder, Folders
et Files dans "Remplir" ci-dessous.
Ca semble bien fonctionner en testant sur l'alphabet cyrilique, et les
noms s'affichent bien en cyrilique également dans le tableau résultat.
NB : je n'ai pas changé le principe de l'algorithme (que j'aurais
peut-être écrit différemment).

Cordialement,
Jean-Claude



Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

ExtLocale = ExtFichier

Dim fs, f, f1, s, sf, n
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(RepertParent)
Set sf = f.Files
n = 0
For Each f1 In sf
If f1.Name Like ExtFichier Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = f1.Name
ActiveCell.Offset(1, -1).Select
n = n + 1
End If
Next
If n = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If

'Compter le nombre de sous-répertoires
Set sf = f.SubFolders
NbreRepert = sf.Count
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
For Each f1 In sf
LeDossierLocal(Compteur) = f1.Name
Compteur = Compteur + 1
Next
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
Call Remplir(ParentLocal, ExtLocale)
Next

'Redéfinir la largeur des colonnes
Columns("A:A").ColumnWidth = 85
Columns("B:B").ColumnWidth = 50

End Sub

Merci pour la solution.

Cependant, je n'ai pas bien compris comment l'utiliser.

Quelle partie du programme dois-je remplacer et par quoi ?

Merci d'avance.

Fabian

"Jean-Claude" <repondre_en_forum@orange.fr> a écrit dans le message de groupe
de discussion : 4e412680$0$30790$ba4acef3@reader.news.orange.fr...

Bonjour,

il semble que ce soit la fonction Dir qui pose problème sur les fichiers ou
répertoires en alphabet non romain.

J'ai supprimé ce Dir et l'ai remplacé par les méthodes SubFolder, Folders
et Files dans "Remplir" ci-dessous.
Ca semble bien fonctionner en testant sur l'alphabet cyrilique, et les noms
s'affichent bien en cyrilique également dans le tableau résultat.
NB : je n'ai pas changé le principe de l'algorithme (que j'aurais peut-être
écrit différemment).

Cordialement,
Jean-Claude



Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

ExtLocale = ExtFichier

Dim fs, f, f1, s, sf, n
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(RepertParent)
Set sf = f.Files
n = 0
For Each f1 In sf
If f1.Name Like ExtFichier Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = f1.Name
ActiveCell.Offset(1, -1).Select
n = n + 1
End If
Next
If n = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If

'Compter le nombre de sous-répertoires
Set sf = f.SubFolders
NbreRepert = sf.Count
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
For Each f1 In sf
LeDossierLocal(Compteur) = f1.Name
Compteur = Compteur + 1
Next
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
Call Remplir(ParentLocal, ExtLocale)
Next

'Redéfinir la largeur des colonnes
Columns("A:A").ColumnWidth = 85
Columns("B:B").ColumnWidth = 50

End Sub

Merci pour la solution.

Cependant, je n'ai pas bien compris comment l'utiliser.

Quelle partie du programme dois-je remplacer et par quoi ?

Merci d'avance.

Fabian

"Fabian" <bertrand@skynet.non> a écrit dans le message de news:
4e421b44$0$5033$ba620e4c@news.skynet.be...

Merci pour la solution.

Cependant, je n'ai pas bien compris comment l'utiliser.

Quelle partie du programme dois-je remplacer et par quoi ?

Merci d'avance.

Fabian

Si tu as un doute, remplace tout ce que tu as copié et collé dans ton
message initial, par tout ce qui est ci-dessous :
(mais seule la partie entre "Sub Remplir" et "End Sub" a été modifiée)
(pour l'utilisation, tu fais comme tu en avais l'habitude)


Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

ExtLocale = ExtFichier

Dim fs, f, f1, s, sf, n
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(RepertParent)
Set sf = f.Files
n = 0
For Each f1 In sf
If f1.Name Like ExtFichier Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = f1.Name
ActiveCell.Offset(1, -1).Select
n = n + 1
End If
Next
If n = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If

'Compter le nombre de sous-répertoires
Set sf = f.SubFolders
NbreRepert = sf.Count
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
For Each f1 In sf
LeDossierLocal(Compteur) = f1.Name
Compteur = Compteur + 1
Next
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
Call Remplir(ParentLocal, ExtLocale)
Next

'Redéfinir la largeur des colonnes
Columns("A:A").ColumnWidth = 85
Columns("B:B").ColumnWidth = 50

End Sub

'Cette macro est lancée en premier
Sub Essai()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim LeMessage As String
Dim Arret As Boolean

LeTitre = "Répertoires et sous-répertoires"
LeMessage = "Taper le nom complet du répertoire"
Arret = False
Application.ScreenUpdating = False
Sheets.Add
Do
LeChemin = ChoisirDossier 'InputBox(LeMessage, LeTitre, LeChemin)
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "" Then
LeChemin = LeChemin + ""
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher",
LeTitre, "*.*")
Call Remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
End Sub

Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash

Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:WindowsBureau"
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
ChoisirDossier = chemin
End Function