'**********************************************************
' fonction récursive pour dir vba
'utilisation de Dir VBA
'auteur: patricktoulon Sur DVP et Exceldownloads
'date:09/11/2016
'
'mises a jour
'date:03/15/2018: utilisation d'une collection pour le stockage provisoire des dossiers
'date 07/02/2021:désormais la fonction compile l'array a la fin de l'appel #1 de la fonction (recall=false)
'date 07/02/2021: ajout de l'argument "PartName"
'date 08/02/2021: ajout d'une fonction de transposition simple pour eviter la limite de la fonction transpose de vba pour 2007 et ceux qui n'on pas installé le KB complement de correction du LAA pour 2013 2010 version disque
'date 09/02/2021: ajout de la gestion d'erreur et correction sur les fichiers portant un nom avec des caracteres spéciaux
' ainsi que les dossiers ou fichiers interdits
'*************************************************************
Option Explicit
Function TransposeArray2(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
TransposeArray2 = tbl
End Function
Sub testDIR_1()
Dim tim#, T, extension$
[A1].CurrentRegion.Clear
extension = "*.*"
tim = Timer
T = DirList("h:\") ', PartName:=extension)
If IsArray(T) Then
MsgBox Timer - tim & " secondes pour " & UBound(T) & " fichier(s)"
[A1].Resize(UBound(T)) = TransposeArray2(T)
Else
MsgBox "pas de fichier"
End If
End Sub
Function DirList(Dossier As String, Optional Recall As Boolean = False, Optional PartName As String = "") As Variant
Dim ItemVu As String, SubFolderCollection As New Collection, I As Long, a As Long, q As Long, criteres, arr1, arr2, subdossier, x
Static tbl$() 'tbl est statique
arr1 = Array("a~", "a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o~", "o`", "o^", "o¨", "u`", "u^", "u¨") 'array caracteres séparés
arr2 = Array("ã", "à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "õ", "ò", "ô", "ö", "ù", "û", "ü") 'array caracteres regroupés
If Recall = False Then ReDim tbl(0) ' si recall on redim un tableau de zero item (pour la creation du tableau)
criteres = vbDirectory Or vbSystem Or vbHidden Or vbArchive Or vbReadOnly Or vbNormal
On Error Resume Next 'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
ItemVu = Dir(Dossier, criteres)
If Error.Number = 0 Then ' si pas d'erreur on examine le contenu
'examen du dossier courrant
Do While ItemVu <> vbNullString 'boucle tant que DIR renvoie une chaine
If ItemVu <> "." And ItemVu <> ".." And Not ItemVu Like "*RECYCLE*" Then
On Error Resume Next
If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then 'test Dossier
If Err.Number > 0 Then 'si erreur c'est un fichier(particulier ou caracteres particulier)
If Err.Number = 53 Then 'si c'est des caracteres bizarres
For q = 0 To UBound(arr1): ItemVu = Replace(Replace(ItemVu, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next 'replace caracteres
If PartName <> "" Then
If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
Else
ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
End If
Else
'si autre erreur
'If PartName <> "" Then
'If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & dossier & ItemVu
'Else
ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
'End If
End If
'si dossier
Else
SubFolderCollection.Add Dossier & ItemVu 'sinon ajout dans la collection de dossier
End If
Err.Clear
Else 'sinon c'est un fichier et pas un concombre:)
'If ItemVu Like PartName Then
If PartName <> "" Then
If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = Dossier & ItemVu
Else
ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = Dossier & ItemVu
End If
End If
End If
ItemVu = Dir()
Loop
Else
Err.Clear 'si erreur a la racine du dir actuel
End If
'examen des sub dossier appel récursif
For Each subdossier In SubFolderCollection
DirList subdossier & "\", True, PartName
Next subdossier
DirList = False
If Not Recall Then DirList = tbl ' return du tableau (apres le dernier appel récursif )'economie de 0.3000 secondes
End Function
