Excel. Liste des fichiers sur mon Ftp

Option Explicit
Option Private Module
'
' Note : il faut activer les références (dans Outils > Références ...) à :
' - Microsoft Scripting Runtime
' - Microsoft Shell Controls And Automation
'

Public Sub Lister_Fichiers()
' Liste les fichiers d'un répertoire et de ses sous-répertoires dans une feuille Excel
' Les informations stockées sont :
' - nom du fichier,
' - chemin complet,
' - répertoire,
' - date de création,
' - date de dernier accés,
' - date de dernière modification,
' - taille,
' - attribut.
'
' Date        Developpeur         Action
' -------------------------------------------------------------------------------------------
' 14/06/10    Patrice             Version 1.0.2
'
Dim objShell As Shell32.Shell          'Shell
Dim objChoix As Shell32.Folder         'Choix de recherche dossier
Dim wbkRapport As Excel.Workbook       'Classeur résultat
Dim rngPlage As Excel.Range            'Plage générique
Dim strChemin As String                'Chemin du dossier
Dim strMsg As String                   'Message de la boite de dialogue

Const WINDOW_HANDLE = 0
Const OPTIONS = 513     'sauf dossiers système et sans le bouton Nouveau dossier

On Error Resume Next

'Afficher la boite de dialogue avec l'arborescence
strMsg = "Choisir le répertoire à analyser :"
Set objShell = New Shell32.Shell
Set objChoix = objShell.BrowseForFolder(WINDOW_HANDLE, strMsg, OPTIONS)

strChemin = objChoix.Items.Item.Path
'strChemin = objChoix.Self.Path

'Si le chemin est valide
If strChemin <> "" Then
  Application.Interactive = False
  '- arrêter l'actualisation écran et les calculs
  Application.Cursor = xlWait
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  '- ajouter un nouveau classeur
  Set wbkRapport = Application.Workbooks.Add(xlWBATWorksheet)
  Set rngPlage = wbkRapport.Worksheets(1).Range(Cells(1, 1), Cells(1, 10))
  '- écrire les en-têtes de colonne
  With rngPlage
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Cells(1, 1).Formula = "Fichier concerné"
    .Cells(1, 2).Formula = "Date de création"
    .Cells(1, 3).Formula = "Date dernier accès"
    .Cells(1, 4).Formula = "Date de dernière modification"
    .Cells(1, 5).Formula = "Taille du fichier en ko"
    .Cells(1, 6).Formula = "Type du fichier"
    .Cells(1, 7).Formula = "Extension"
    .Cells(1, 8).Formula = "Attributs"
    .Cells(1, 9).Formula = "Chemin d'accès au fichier"
    .Cells(1, 10).Formula = "Chemin complet du fichier"
    .Columns.AutoFit
  End With
  '- lister l'arborescence du dossier
  Call ListerDossier(strChemin, wbkRapport)
  '- rétablir l'actualisation écran et les calculs
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.Cursor = xlDefault
  Application.Interactive = True
End If

Set objShell = Nothing
Set objChoix = Nothing

End Sub
  
Private Sub ListerDossier(strChemin As String, wbkRapport As Excel.Workbook)
' Procédure récursive qui liste l'arborescence du dossier (et des sous-dossiers)
'
' Arguments : strChemin           [in] Chemin du dossier à explorer
'             wbkRapport          [in] Fichier rapport
'
' Date        Developpeur         Action
' -------------------------------------------------------------------------------------------
' 14/06/10    Patrice             Version 1.0.2
'
Dim objFSO As FileSystemObject         'File System Object
Dim objRep As Scripting.Folder         'Dossier à analyser
Dim objSubRep As Scripting.Folders     'Collection de Sous-dossiers
Dim objSubRepItem As Scripting.Folder  'Sous-dossier
Dim objSubFile As Scripting.Files      'Collection des fichiers du dossier
Dim objSubFileItem As Scripting.File   'Fichier cherché
Dim rngPlage As Excel.Range            'Plage générique
Dim strAtt As String                   'Attributs du fichier
Dim n°L As Integer                     'N° de la ligne à écrire sur la feuille de calcul
Dim att As Integer                     'Valeur des attributs du fichier

Dim adr As String
Dim ctr As Integer


On Error Resume Next
'Explorer le dossier
Set objFSO = New FileSystemObject
Set objRep = objFSO.GetFolder(strChemin)                'dossier
Set objSubRep = objRep.SubFolders                       'sous-dossiers
'- traiter chaque sous-dossier
For Each objSubRepItem In objSubRep
  Call ListerDossier(objSubRepItem.Path, wbkRapport)    'appel recursif
Next
Set objSubFile = objRep.Files                           'fichiers
'- traiter chaque fichier
For Each objSubFileItem In objSubFile
  '-- affectation du nom des attributs
  att = objSubFileItem.Attributes
  strAtt = ""
  If att = 0 Then strAtt = "Aucun"
  If att And 8 Then strAtt = strAtt & "V "              'Volume
  If att And 16 Then strAtt = strAtt & "D "             'Directory
  If att And 1 Then strAtt = strAtt & "R"              'Read Only
  If att And 2 Then strAtt = strAtt & "H"              'Hidden
  If att And 4 Then strAtt = strAtt & "S"              'System
  If att And 32 Then strAtt = strAtt & "A"             'Archive
  If att And 1024 Then strAtt = strAtt & " Alias"
  If att And 2048 Then strAtt = strAtt & " Compressed"
  '-- écriture de la ligne sur la feuille de calcul
  Set rngPlage = wbkRapport.Worksheets(1).Range(Cells(1, 1), Cells(1, 10))
  Set rngPlage = rngPlage.Offset(wbkRapport.Worksheets(1).UsedRange.Rows.Count)
  With rngPlage
    adr = .Address
    .Cells(1, 1).Formula = objSubFileItem.Name
    .Cells(1, 2).Formula = objSubFileItem.DateCreated
    .Cells(1, 3).Formula = objSubFileItem.DateLastAccessed
    .Cells(1, 4).Formula = objSubFileItem.DateLastModified
    .Cells(1, 5).Formula = Arrondi(objSubFileItem.Size / 1024, 0)
    .Cells(1, 5).HorizontalAlignment = xlCenter
    .Cells(1, 6).Formula = objSubFileItem.Type
    .Cells(1, 7).Formula = objFSO.GetExtensionName(objSubFileItem.Name)
    .Cells(1, 7).HorizontalAlignment = xlCenter
    .Cells(1, 8).Formula = strAtt
    .Cells(1, 8).HorizontalAlignment = xlCenter
    .Cells(1, 9).Formula = objSubFileItem.ParentFolder
    .Cells(1, 10).Formula = objSubFileItem.Path
'    .Offset(1 - .Row).Resize(.Row).Columns.AutoFit
  End With
Next
If Not rngPlage Is Nothing Then
  rngPlage.Offset(1 - rngPlage.Row).Resize(rngPlage.Row).Columns.AutoFit
  Set rngPlage = Nothing
End If
Set objFSO = Nothing
Set objRep = Nothing
Set objSubRep = Nothing
Set objSubRepItem = Nothing
Set objSubFile = Nothing
Set objSubFileItem = Nothing

End Sub

Private Function Arrondi(ByVal Nombre, ByVal Decimales)
' Remplace la fonction VBA Round() qui fonctionne mal pour les
' nombres de la forme 2a + 0,5 (arrondis à l'inférieur !!!)
'
' Arguments : Nombre              [in] Nombre à arrondir
'             Décimales           [in] Nombre de décimales
'
' Date        Developpeur         Action
' -------------------------------------------------------------------------------------------
' 28/08/06    Patrice             Version 2.0
'
Arrondi = Int(Nombre * 10 ^ Decimales + 1 / 2) / 10 ^ Decimales

End Function