EXPLORATEUR DE FICHIERS VBA (LE DRIVE+DIR+FILELISTBOX DU VB)

'Fonction de tri d'une liste dans l'ordre alphabétique
Public Function Prog_tri_croissant(ByRef Var_liste())

  For Var_compteur1 = LBound(Var_liste) To UBound(Var_liste) - 1
    For Var_compteur2 = Var_compteur1 + 1 To UBound(Var_liste)
      If Var_liste(Var_compteur1) > Var_liste(Var_compteur2) Then
        Var_temp = Var_liste(Var_compteur2)
        Var_liste(Var_compteur2) = Var_liste(Var_compteur1)
        Var_liste(Var_compteur1) = Var_temp
      End If
    Next Var_compteur2
  Next Var_compteur1

'Affectation de la valeur finale au programme pour qu'il retourne
'la liste dans l'ordre croissant lorsque l'on fait appel à lui
Prog_tri_croissant = Var_liste()

End Function

'Programme d'affichage des répertoires et des fichiers
Sub Prog_affichage_rep_et_fichier()

  Var_chemin = TextBox1.Value
  Dim Obj_FSO, Obj_dossier
  Var_rep = ""
  Var_fich = ""

  On Error Resume Next

  ' Créer une instance du FSO (Objet système de fichiers)
  Set Obj_FSO = CreateObject("Scripting.FileSystemObject")
  Set Obj_dossier = Obj_FSO.GetFolder(Var_chemin)

  Var_nb_rep = Obj_dossier.SubFolders.Count
  ReDim Var_liste_rep(Var_nb_rep)
  Var_compteur1 = 1
  'Créer la liste des répertoires du lecteur sélectionné
  For Each Var_rep In Obj_dossier.SubFolders
    'Affecter des noms de répertoire en majuscules (Ucase) pour un tri futur
    Var_liste_rep(Var_compteur1) = UCase(Var_rep.Name)
    Var_compteur1 = Var_compteur1 + 1
  Next

  'Faire appel au sous-programme de tri croissant d'une liste
  Var_liste_triee = Prog_tri_croissant(Var_liste_rep)

  For Var_compteur = 1 To Var_nb_rep
    ListBox1.AddItem Var_liste_triee(Var_compteur)
  Next Var_compteur
  
  ' Ajouter la racine (..) en premier dans la liste des répertoires
  ' seulement dans le cas où on est au niveau inférieur d'un lecteur
  ' (Exemple "C:\" fait 3 caractères)
  If Len(Var_chemin) > 3 Then
    'Ajouter le ".." en tête de liste
    ListBox1.AddItem "..", 0
  End If
  
  Var_compteur = 1
  Var_nb_fich = Obj_dossier.Files.Count
  ReDim Var_liste_fich(Var_nb_fich)
  'Créer la liste des fichiers du repertoire sélectionné
  For Each Var_fich In Obj_dossier.Files
'Réactiver la condition If suivante si vous ne voulez voir que les fichiers DWG
'    If Right(Var_fich.Name, 4) = ".dwg" Or Right(Var_fich.Name, 4) = ".DWG" Then
      'Affecter des noms de fichiers en majuscules (Ucase) pour un tri futur
      Var_liste_fich(Var_compteur) = UCase(Var_fich.Name)
      Var_compteur = Var_compteur + 1
'    End If
  Next
  
  'Redimensionner le tableau (composé d'un nombre d'éléments correspondant
  'au nombre total des fichiers du répertoire) par un nombre d'éléments
  'correspondant au nombre de fichiers ".dwg" du répertoire
  'Fonction ne supprimant que les valeurs supérieures de la différence des 2 nb d'éléments
  ReDim Preserve Var_liste_fich(Var_compteur - 1)
  
  'Faire appel au sous-programme de tri croissant d'une liste
  Var_liste_triee = Prog_tri_croissant(Var_liste_fich)

  For Var_compteur = 1 To Var_nb_fich
    ListBox2.AddItem Var_liste_triee(Var_compteur)
  Next Var_compteur
  
  ' Libérer les objets
  Set Obj_FSO = Nothing
  Set Obj_dossier = Nothing
  
End Sub

Sub Prog_recherche_lecteurs()

  Dim Obj_FSO

  On Error Resume Next

  ' Créer une instance du FSO (Objet système de fichiers)
  Set Obj_FSO = CreateObject("Scripting.FileSystemObject")

  For Each drvValue In Obj_FSO.Drives
    'Ne pas tenir compte du lecteur A
    If drvValue.DriveLetter <> "A" Then
      'Regarder si le lecteur est disponible
      If drvValue.Isready Then
        'Le lecteur est disponible :
        'Ajouter son nom dans la liste de ComboBox1 avec :\ au bout du nom
        ComboBox1.AddItem drvValue.DriveLetter & ":\"
      End If
    End If
  Next

  ' Libérer les objets
  Set Obj_FSO = Nothing

End Sub

'Liste déroulante des lecteurs
Private Sub ComboBox1_Change()
  TextBox1.Value = ComboBox1.Value
  'Effacer le contenu de la liste de répetoires
  ListBox1.Clear
  'Effacer le contenu de la liste des fichiers
  ListBox2.Clear
  Call Prog_affichage_rep_et_fichier
End Sub

'Liste des répertoires
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  On Error GoTo Error
  If ListBox1.Value = ".." Then
    'Si choix de l'utilisateur de ".."
    Dim Var_boucle As Integer
    Dim Var_position_barre As Integer
    For Var_boucle = 3 To Len(TextBox1.Value)
      'Si on détecte le dernier "\" dans la chaine de caractères : sortir de la boucle
      'de manière à ne garder en mémoire que la position de l'avant-dernière "\"
      If InStr(Var_boucle, TextBox1.Value, "\") = Len(TextBox1.Value) Then Exit For
      Var_position_barre = InStr(Var_boucle, TextBox1.Value, "\")
    Next Var_boucle
      'Supprimer le dernier sous-répertoire pour remonter d'un niveau
      TextBox1.Value = Left(TextBox1.Value, Var_position_barre)
  Else
    'Sinon ajouter le choix du nouveau sous-répertoire
    TextBox1.Value = TextBox1.Value & ListBox1.Value & "\"
  End If
  ListBox1.Clear
  ListBox2.Clear
  Call Prog_affichage_rep_et_fichier
  'Se placer tout en haut de la liste
  ListBox1.TopIndex = 0
  'Déselectionner une sélection unique dans une liste Box dont Multiselect est sur 0
  ListBox1.ListIndex = -1
Error:
End Sub

Private Sub UserForm_Activate()
  'A l'activation du programme, lancer la recherche des lecteurs.
  Call Prog_recherche_lecteurs
End Sub

Télécharger le zip