Soyez le premier à donner votre avis sur cette source.
Vue 19 065 fois - Téléchargée 1 107 fois
'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
je te permets pas te me juger, reste en à tes remarques concernant le code!!!
J'ai quand même fait qq modifs pour la forme et obtimiser le nombre de variables.
Bref, merci
Zavier666 n'a pas l'air trés intelligent comme garçon!! La critique est facile !!
A quelques modifs près, ce code n'est ni puls ni moins qu'une retranscirption de l'aide dispo pour VBA !!???!!!!!
stls!
_______________________________________________
Toujours plus de VB6 et d'APi => API @ la loupe
http://xav.prog.power.fr
Déjà ton code est bien lisible...cool!
8/10
A+
Exploreur
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.