Liste du contenu des dossiers en vba sous excel ou word

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

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)