Liste du contenu des dossiers en vba sous excel ou word

Soyez le premier à donner votre avis sur cette source.

Vue 22 514 fois - Téléchargée 1 529 fois

Télécharger le projet
Commenter

Description

Une form permettant de choisir :
- le dossier de départ
- le listage de tous les fichiers ou de certains types de fichiers
- le caractère récursif (lister aussi le contenu des sous dossiers)
- le format de présentation (nom court, extension, ...)

Utiliser :
Positionner le curseur là où l'on souhaite la liste
Lancer le formulaire avec VBA
C'est fait !

Installer :
télécharger le code - dé zipper
aller dans VB editor (Excel ou Word) - Testé seulement avec Office 2003 !
importer la forme : ALL_ListeLesFichiers_20080528.frm
(menu fichier - option importer un fichier)

Source / Exemple : 


Public NbDir As Long
Public CompteurDir

Private Sub Chercher_Click()
Dim MyFile As String

DossierInitial.Value = Select_A_Folder("Sélectionnez le dossier à lister", "x:\") + "\"
DossierInitial_AfterUpdate
End Sub

Private Sub DossierInitial_AfterUpdate()
Dim MyFile, MyPath, MyName As String

MyPath = DossierInitial.Value ' Définit le chemin d'accès.
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath + "\"
    DossierInitial.Value = MyPath
End If

CompteurDir = TousLesDossiers(MyPath)
NbDir = (UBound(CompteurDir) - LBound(CompteurDir) + 1)
SubFolders.Caption = "Lister les " + CStr(NbDir) + " sous dossiers également"
      
    
End Sub

Private Sub BoutonOK_Click()
Dim typefichier, Localisation, Item As String
Dim ListedeFichiers
Dim Message, Title, Default, MyValue As String
Dim NbFiles, i, k As Long

k = 1
typedefichier = AutreTypeDeFichiers.Text
Localisation = DossierInitial.Value             ' dossier à lister

Lister:

OutputTitre (Localisation)                      'imprime le nom du dossier
ListedeFichiers = TousLesFichiers(Localisation) 'crée une table des fichiers du dossier
NbFiles = (UBound(ListedeFichiers) - LBound(ListedeFichiers) + 1)

For i = 1 To NbFiles

If OptionButton2.Value Then
    Item = ListedeFichiers(i)
Else
    Item = NomCourtDe(ListedeFichiers(i))
    If CheckBox1.Value Then Item = Item + ExtensionDe(ListedeFichiers(i))
End If

If Selectous Then Output (Item): GoTo jump
If selectdoc And (ExtensionDe(ListedeFichiers(i)) = ".doc") Then Output (Item)
If selectxls And (ExtensionDe(ListedeFichiers(i)) = ".xls") Then Output (Item)
If selectppt And (ExtensionDe(ListedeFichiers(i)) = ".ppt") Then Output (Item)
If selectpdf And (ExtensionDe(ListedeFichiers(i)) = ".pdf") Then Output (Item)
If Selectautre And (ExtensionDe(ListedeFichiers(i)) = typedefichier) Then Output (Item)
jump::
Next
Output (vbCr)

If SubFolders.Value Then
    k = k + 1
    If k > NbDir Then Exit Sub
    Localisation = CompteurDir(k)
    GoTo Lister
End If

End Sub

Private Sub BoutonAnnule_Click()
ListeLesFichiers.Hide           ' Masque le formulaire
Unload ListeLesFichiers         ' Décharge le formulaire de la mémoire

End Sub

Function Select_A_Folder(Message, directory)
Dim Ok As Boolean
Dim objShell, objFolder, objFolderItem

    Ok = False
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder _
        (WINDOW_HANDLE, Message, NO_OPTIONS, directory)

    On Error Resume Next
    
    Set objFolderItem = objFolder.Self
    If Err <> 0 Then
        Select_A_Folder = "ANNUL"
    Else
        Select_A_Folder = objFolderItem.Path
        Ok = True
    End If

End Function

Function TousLesDossiers(LeDossier)
Dim MyPath, MyName, Result() As String
Dim i, j, k, Debut As Long

ReDim Result(1 To 1)
Result(1) = LeDossier                           ' Dossier initial inscrit dans la liste en constitution
If Right(Result(1), 1) = "\" Then Result(1) = Left(Result(1), Len(Result(1)) - 1)
k = 1                                           ' A ce stade un seul dossier en tout et pour tout
i = 1                                           ' donc une seule ligne dans la liste
Debut = 1                                       ' on commence par le premier dossier connu mais pas analysé

boucle::
For j = Debut To k                              ' Prépare une boucle sur la liste des dossiers connus
MyName = Dir(Result(j) + "\", vbDirectory)      ' Extrait la première entrée du dossier en cours d'analyse
MyPath = Result(j) + "\"                        ' Stocke son nom dans un tableau
Do While MyName <> ""                           ' Commence la boucle dans les sous répertoires de ce dossier
                                                ' Ignore le dossier courant et le dossier
    If MyName <> "." And MyName <> ".." Then    ' contenant le dossier courant.
        MyName = MyPath + MyName          ' le stocke sous forme de dossier (chemin complet)
                                                ' Utilise une comparaison au niveau du bit pour
        If (GetAttr(MyName) And vbDirectory) = vbDirectory Then     ' vérifier que MyName est un dossier.
            i = i + 1                           ' Incrémente le compteur des sous dossiers trouvés
            ReDim Preserve Result(1 To i)       ' Ajuste la taille du tableau aux sous dossiers trouvés
            Result(i) = MyName                  ' Stocke le nom du dossier dans le tableau.
       End If
    End If
    MyName = Dir                                ' Extrait l'entrée suivante.
Loop                                            ' Boucle sur les items du dossier analysé
Next                                            ' Boucle sur la liste des dossiers à analyser

If k = (UBound(Result) - LBound(Result) + 1) Then   ' Compte les dossiers inscrits au tableau.
    GoTo suite                                  ' Si le nombre n'a pas changé en balayant la liste => stop
End If

Debut = k + 1                                   ' Si nom il faut compléter l'analyse sur les sous dossiers
k = (UBound(Result) - LBound(Result) + 1)       ' trouvés (jusqu'au dernier inscrit dans le tableau)
GoTo boucle                                     ' Renvoie à la double boucle de recherche

suite::
TousLesDossiers = Result                        ' transfère le tableau comme résultat de la fonction

End Function

Function TousLesFichiers(Dossier)
Dim Result()
Dim MyName, MyPath As String
Dim i  As Integer
ReDim Result(1 To 1)

If Right(Dossier, 1) <> "\" Then Dossier = Dossier + "\"

MyName = Dir(Dossier) ' Extrait la première entrée.
MyPath = Dossier
Result(1) = Dossier

Do While MyName <> ""    ' Commence la boucle.
    ' Ignore le dossier courant et le dossier
    ' contenant le dossier courant.
    If MyName <> "." And MyName <> ".." Then
        ' Utilise une comparaison au niveau du bit pour
        ' vérifier que MyName est un dossier.
        MyName = MyPath + MyName
        If (GetAttr(MyName) And vbNormal) = vbNormal Then
            i = i + 1
            ReDim Preserve Result(1 To i)
            Result(i) = MyName
       End If    ' représente un dossier.
    End If
    MyName = Dir    ' Extrait l'entrée suivante.
Loop

TousLesFichiers = Result
End Function

Function Output(Message)
If Application.Name = "Microsoft Excel" Then
    ActiveCell.Value = Message
    ActiveCell.Offset(1, 0).Select
    Output = "Excel"
ElseIf Application.Name = "Microsoft Word" Then
    Selection.TypeText Text:=Message + vbCr
    Output = "Word"
Else
    MsgBox (Message)
    Output = "Other"
End If
End Function

Function OutputTitre(Message)
If Application.Name = "Microsoft Excel" Then
    ActiveCell.Value = Message
    ActiveCell.Font.Color = RGB(255, 0, 0)
    ActiveCell.Font.Bold = True
    ActiveCell.Columns.AutoFit
    ActiveCell.Offset(1, 0).Select
    OutputTitre = "Excel"
ElseIf Application.Name = "Microsoft Word" Then
    Selection.TypeText Text:=Message
    Selection.InlineShapes.AddHorizontalLineStandard
    Selection.TypeText Text:=vbCr
    OutputTitre = "Word"
Else
    MsgBox (Message)
    OutputTitre = "Other"
End If
End Function

Function ExtensionDe(ByVal Fichier As String)
On Error GoTo 0
ExtensionDe = Right(Fichier, 4)
End Function

Function NomCourtDe(ByVal Fichier As String)
On Error GoTo 0
NomCourtDe = Mid(Fichier, InStrRev(Fichier, "\") + 1, Len(Mid(Fichier, InStrRev(Fichier, "\") + 1)) - 4)
End Function

Conclusion :


J'ai eu plusieurs difficultés (lister les dossiers, transférer un tableau entre procédures, choisir un dossier, distinguer fichier et dossiers, ...).

Merci aux auteurs (sites vbfrance, développez.com, ...) qui ont mis en ligne le code qui m'a aidé à résoudre ces difficultés.

C'est sympa et rapide. Les fonctions peuvent reservir ailleurs ...
Bonne utilisation !
Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Signaler
Philippe_Marcovitch
Messages postés
3
Date d'inscription
vendredi 7 octobre 2005
Statut
Membre
Dernière intervention
10 juillet 2008
 -
Bonjour Jean-Luc,

Voici le code d'erreur lorsque le veux importer le fichier frm : "Ligne 8 : La propriété OleObjectBlob dans ListeLesFichiers a une référence de fichier incorrecte.". Je précise que suis toujours en Office 2000 !.
Bien à toi,

Philippe
Signaler
rct100
Messages postés
1
Date d'inscription
lundi 30 juin 2008
Statut
Membre
Dernière intervention
10 juillet 2008
 -
Bonjour,

J'ai eu le même problème que Philippe, et je suis en Office 2003.
Signaler
cs_gege45
Messages postés
5
Date d'inscription
mercredi 28 janvier 2004
Statut
Membre
Dernière intervention
1 octobre 2013
 -
Bonjour, Huuum

Quand tu écris les lignes suivantes

Aller dans VB editor (Excel ou Word) - Testé seulement avec Office 2003 !
Importer la forme : ALL_ListeLesFichiers_20080528.frm
(menu fichier - option importer un fichier)

J’ai un doute que tu l’ais teste sous Excel 2003 car il ne semble que les boite de dialogue Frm Visual Basic et les UserForm d’Excel n’ont pas la même structure. Les frm VB elles ne sont pas gérées dans VBE Excel. Donc le fichier ne peut pas être chargé.
Tu devrais mettre le fichier XLS.
Signaler
mynyroger
Messages postés
20
Date d'inscription
mardi 25 février 2003
Statut
Membre
Dernière intervention
1 février 2010
 -
J'ai eu le même problème que Philippe, et je suis en Office 2007
Signaler
cs_Le Pivert
Messages postés
6345
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
15 novembre 2019
 88 -
Ton code fonctionne très bien, mais j'ai été obligé
d'ouvrir une forme en VBA et de m'aider de la capture qui était dans ton zip pour le faire coller à ton code. Il aurait été plus simple d'envoyer le fichier Excel dans ton zip.
Afficher les 13 commentaires
S'inscrire maintenant

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.

Du même auteur (klhsri)