Soyez le premier à donner votre avis sur cette source.
Vue 24 364 fois - Téléchargée 1 619 fois
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
5 mars 2015 à 13:33
http://www.cjoint.com/data3/3CfnRoTCFqn.htm
4 mars 2015 à 15:23
Cdlt
27 févr. 2011 à 23:02
23 févr. 2011 à 21:46
Le programme ne comprend pas les sous-dossiers. Veillez m'aider SVP !
23 févr. 2011 à 21:07
Ceci marche à merveille. Merci à Pascal.
Biensûr un grand merci à klhsri également qui a mis le code en ligne. Le programme est hyper complet et mérite d'être saluer.
Encore Merci !
Djibril.
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.