Lister tous les fichiers d'un dossier et de ses sous-dossiers

Soyez le premier à donner votre avis sur cette source.

Snippet vu 15 340 fois - Téléchargée 35 fois

Contenu du snippet

Lister tous les fichiers d'un dossier et de ses sous-dossiers
source net

Source / Exemple :


Attribute VB_Name = "ListeFichiersEtDossiers"

Option Explicit

 '32-bit API declarations
 
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Sub ListFiles()

Dim msg As String, answer As String
Dim Directory As String
Dim R As Integer
Dim i As Integer
Dim StartDate As Single
     
          
  msg = "Select a location containing the files you want to list."
  Directory = GetDirectory(msg)
  If Directory = "" Then Exit Sub
  If Right(Directory, 1) <> "\" Then Directory = Directory & "\"

 '   Insert headers
     
  R = ActiveCell.Row
  Cells(R, 1) = "FilePath"
  Cells(R, 2) = "Size"
  Cells(R, 3) = "Date/Time"
  Cells(R, 4) = "Filename"
  Range("A1:C1").Font.Bold = True
  R = R + 1

  On Error Resume Next
  With Application.FileSearch
    .NewSearch
    .LookIn = Directory
    .Filename = "*.*"  ' this can be '*.*
    .SearchSubFolders = True
    .Execute
    For i = 1 To .FoundFiles.Count
      If FileDateTime(.FoundFiles(i)) > StartDate Then
        Cells(R, 1) = .FoundFiles(i)
        Cells(R, 4) = Right(Cells(R, 1), Len(.FoundFiles(i)) - InStrRev(Cells(R, 1).Value, "\"))
        Cells(R, 2) = FileLen(.FoundFiles(i))
        Cells(R, 3) = FileDateTime(.FoundFiles(i))
        R = R + 1
      End If
    Next i
  End With
  'Columns("A:C").Select
  'Selection.Columns.AutoFit
    
  'ActiveSheet.Columns("1:3").AutoFit
  MsgBox "file listing complete"
 
End Sub

 Function GetDirectory(Optional msg) As String
     Dim bInfo As BROWSEINFO
     Dim path As String
     Dim R As Long, x As Long, pos As Integer

 ' Root folder = Desktop
     bInfo.pidlRoot = 0&

 ' Title in the dialog
     If IsMissing(msg) Then
         bInfo.lpszTitle = "Select a folder"
     Else
         bInfo.lpszTitle = msg
   End If

 ' Type of directory to return
     bInfo.ulFlags = &H1

 ' Display the dialog
     x = SHBrowseForFolder(bInfo)

 ' Parse the result
     path = Space$(512)
     R = SHGetPathFromIDList(ByVal x, ByVal path)
     If R Then
         pos = InStr(path, Chr$(0))
         GetDirectory = Left(path, pos - 1)
     Else
         GetDirectory = ""
   End If
 End Function

Function InStrLast(iStart As Integer, szSrchIn As String, _
                    szSrchFor As String, iCompare As Integer) As Integer
Dim iPrevFoundAt As Integer
Dim iFoundAt As Integer
    On Error GoTo ErrExit_InStrLast
    iPrevFoundAt = 0
    iFoundAt = InStr(iStart, szSrchIn, szSrchFor, iCompare)
    Do While iFoundAt > 0
        iPrevFoundAt = iFoundAt
        iFoundAt = InStr(iPrevFoundAt + 1, szSrchIn, szSrchFor, iCompare)
    Loop
ErrExit_InStrLast:
    If Err <> 0 Then MsgBox Error$, vbExclamation
    InStrLast = iPrevFoundAt
    Exit Function
End Function

A voir également

Ajouter un commentaire

Commentaires

Messages postés
1
Date d'inscription
mercredi 8 juin 2011
Statut
Membre
Dernière intervention
8 juin 2011

Pourquoi quand je cherche à l’exécuter il me met l'erreur: "erreur de syntaxe"
Messages postés
940
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
3 février 2011
7
Marche à la perfection, bravo.
Infos pour les noobs
Ce code est à mettre sous Excel... pour cela, faire :
Alt+F11 => Insertion => module => copier/coller du code
Ctrl + H pour enlever les #
Sauvegarde Ctrl + S
Puis Alt + F8 => exécuter
Choisir le dossier a afficher et hop!, "c'est la magie"
Messages postés
2
Date d'inscription
mardi 25 janvier 2005
Statut
Membre
Dernière intervention
1 avril 2005

C'est intéressant!

Est ce que tu n'a pas de code pour VB pour cette application! Ou bien comment l'exporter vers un Exe VB.

Je l'exporterai pour une application Réseau, si tu le veux bien.
Messages postés
2
Date d'inscription
jeudi 12 juin 2003
Statut
Membre
Dernière intervention
13 janvier 2004

il manque la fonction InStrRev pour que ça marche

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.