Relever le nom des fichiers Visual Basic

'Script d'analyse des fichiers d'un disque
'-----------------------------------------
'
'Description :
'°°°°°°°°°°°°°
'Ce script stocke les informations des fichiers contenus dans un répertoire ou
'disque donné dans un fichier texte. 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.
'Ces informations sont séparées par des tabulations (format: .txt)
'

  Dim objWSS, objFSO, objShell, objChoix, objDossier
  Dim strChemin, strBureau, strRapport, strSep, strMsg
  Dim Fichier
  Dim Ctr

  Set objWSS = CreateObject("WScript.Shell")
  Set objFSO = CreateObject("Scripting.FileSystemObject")

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

  On Error Resume Next

  'Affichage de l'arborescence
  strMsg = "Choisir le répertoire à analyser :"
  Set objShell = CreateObject("Shell.Application")
  Set objChoix = objShell.BrowseForFolder(WINDOW_HANDLE, strMsg, OPTIONS)
  Set objDossier = objChoix.Self
  strChemin = objDossier.path

  'Si le chemin est valide
  If strChemin <> "" Then
    'Dossier Bureau de windows + "\"
    strBureau = objWSS.SpecialFolders("Desktop")
    If Right(strBureau, 1) <> "\" Then strBureau = strBureau & "\"
    
    'Création et ouverture fichier pour l'arborescence du répertoire à traiter
    strRapport = "Liste des Fichiers.txt"
    Set Fichier = objFSO.CreateTextFile(strBureau & strRapport, 1, True)
    
    'Écriture de la premiere ligne de la liste
    strSep = Chr(9)
    strMsg = "Fichier concerné"
    strMsg = strMsg & strSep & "Chemin complet du fichier"
    strMsg = strMsg & strSep & "Chemin d'accès au fichier"
    strMsg = strMsg & strSep & "Date de création"
    strMsg = strMsg & strSep & "Date dernier accès"
    strMsg = strMsg & strSep & "Date de dernière modification"
    strMsg = strMsg & strSep & "Taille du fichier en ko"
    strMsg = strMsg & strSep & "Type du fichier"
    strMsg = strMsg & strSep & "Extension"
    strMsg = strMsg & strSep & "Attribut"
    Fichier.WriteLine (strMsg)

    'Lister l'arborescence du dossier
    ListerDossierTxt strChemin, Fichier, Ctr

    Fichier.WriteLine
    Fichier.WriteLine "Nombre de Fichiers :  " & Ctr

    strMsg = "Ecriture du résultat sur le Bureau,"
    strMsg = strMsg & vbCR & vbCR
    strMsg = strMsg & "dans «" & strRapport & "»"
    MsgBox strMsg, vbOKOnly + vbInformation, "Confirmation"
 
    'Fermeture du fichier contenant l'arborescence du répertoire à traiter
    Fichier.Close
    
    Set objWSS = Nothing
    Set objFSO = Nothing
    Set objShell = Nothing
    Set objChoix = Nothing
    Set objDossier = Nothing
    Set Fichier = Nothing
    
    Set objRep = Nothing
    Set objSubRep = Nothing
    Set objRepFind = Nothing
    Set objSubFile = Nothing
    
  End If

  
Function ListerDossierTxt(strChemin, Fichier, Ctr)
'Liste l'arborescence du dossier
  Dim objFSO, objRep, objSubRep, objSubRepItem
  Dim objRepFind, objSubFile, objSubFileItem
  Dim strSep, strTxt, att
  
  On Error Resume Next
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objRep = objFSO.GetFolder(strChemin)         'dossier
  Set objSubRep = objRep.SubFolders                'sous-dossiers
  For Each objSubRepItem In objSubRep              'traiter chaque sous-dossier
    ListerDossierTxt objSubRepItem.path, Fichier, Ctr   ' appel recursif
  Next
  Set objRepFind = objFSO.GetFolder(strChemin)     'dossier
  Set objSubFile = objRepFind.Files                'fichiers
  Set objShell = CreateObject("Shell.Application")
  Set objFolder = objShell.Namespace(strChemin)
  For Each objSubFileItem In objSubFile            'traiter chaque fichier
    'Récupératon de l'attribut du fichier
    att = objSubFileItem.Attributes
    'Affectation du numéro de l'attribut à son nom
    Select Case att
      Case 0
        Attribut = "Normal"
      Case 1
        Attribut = "Read Only"
      Case 2
        Attribut = "Hidden"
      Case 4
        Attribut = "System"
      Case 8
        Attribut = "Volume"
      Case 16
        Attribut = "Directory"
      Case 32
        Attribut = "Archive"
      Case 1024
        Attribut = "Alias"
      Case 2048
        Attribut = "Compressed"
      Case Else
        Attribut = "Inconnu"
    End Select
    'Ecriture dans le fichier
    strSep = Chr(9)
    strMsg = objSubFileItem.name
    strMsg = strMsg & strSep & objSubFileItem.path
    strMsg = strMsg & strSep & objSubFileItem.ParentFolder
    strMsg = strMsg & strSep & objSubFileItem.DateCreated
    strMsg = strMsg & strSep & objSubFileItem.DateLastAccessed
    strMsg = strMsg & strSep & objSubFileItem.DateLastModified
    strMsg = strMsg & strSep & objSubFileItem.Size
    strMsg = strMsg & strSep & objSubFileItem.Type
    strMsg = strMsg & strSep & objFSO.GetExtensionName(objSubFileItem.name)
    strMsg = strMsg & strSep & Attribut
    Fichier.WriteLine strMsg
    Ctr = Ctr + 1
  Next
End Function