LISTE DU CONTENU DES DOSSIERS EN VBA SOUS EXCEL OU WORD

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

Télécharger le zip