Sub TestFichiersRépertoireFSO()
Dim Table As Variant, tim#
Const Répertoire = "H:"
tim = Timer
Table = FichiersRépertoireFSO(Répertoire, , "*.txt")
Table = TransposeExcel(Table)
If IsArray(Table) Then
MsgBox UBound(Table) & " fichier(s) trouvé(s) dans le répertoire <" & Répertoire & "> en " & Timer - tim & " s/"
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table
Else
MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">"
End If
End Sub
Function FichiersRépertoireFSO(ByVal NomRépertoire As Variant, Optional NoRecycle As Boolean = True, Optional Ext As String = "*.*") As Variant
Static TabNomsFichiers() As String
Static NbFichiers As Long
Static oFSO As Object
Dim oDir As Object
Dim oSubDir As Object
Dim oFile As Object
Dim InitialCall As Boolean
If TypeOf NomRépertoire Is Object Then
InitialCall = False
Set oDir = NomRépertoire
Else
InitialCall = True
Erase TabNomsFichiers
NbFichiers = 0
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
Set oDir = oFSO.GetFolder(NomRépertoire)
End If
If oDir.Name = "System Volume Information" _
Or (NoRecycle And oDir.Name = "$RECYCLE.BIN") Then Exit Function
On Error Resume Next
For Each oFile In oDir.Files
If Err.Number = 0 Then
If oFile.Name Like Ext Then
NbFichiers = NbFichiers + 1
ReDim Preserve TabNomsFichiers(1 To NbFichiers)
TabNomsFichiers(NbFichiers) = oFile.Path
End If
Else
If Not (Err.Number = 70 Or Err.Number = 76) Then MsgBox "FichiersRépertoireFSO erreur #" & Err.Number
Err.Clear
End If
Next oFile
On Error GoTo 0
For Each oSubDir In oDir.SubFolders
Call FichiersRépertoireFSO(oSubDir, NoRecycle, Ext)
Next oSubDir
If InitialCall Then
FichiersRépertoireFSO = False
If NbFichiers > 0 Then FichiersRépertoireFSO = TabNomsFichiers
End If
End Function
Function TransposeExcel(t As Variant) As Variant
Dim tt() As Variant
Dim NbDimensions As Integer
Dim i As Long
Dim j As Long
If Not IsArray(t) Then
MsgBox "Function TransposeExcel: error argument is not an array !"
Exit Function
End If
On Error Resume Next
i = UBound(t, 2)
If Err.Number Then NbDimensions = 1 Else NbDimensions = 2
On Error GoTo 0
If NbDimensions = 1 Then
ReDim tt(LBound(t) To UBound(t), 1 To 1)
For i = LBound(t) To UBound(t)
tt(i, 1) = t(i)
Next i
End If
If NbDimensions = 2 Then
If UBound(t, 2) = 1 Then
ReDim tt(LBound(t, 1) To UBound(t, 1))
For i = LBound(t, 1) To UBound(t, 1)
tt(i) = t(i, 1)
Next i
Else
ReDim tt(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
For i = LBound(t, 2) To UBound(t, 2)
For j = LBound(t, 1) To UBound(t, 1)
tt(i, j) = t(j, i)
Next j
Next i
End If
End If
TransposeExcel = tt
End Function
