Choix et exploration répertoire et sous repertoires

pouloucarine Messages postés 8 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 26 novembre 2015 - Modifié par Whismeril le 14/02/2015 à 11:11
ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 - 14 févr. 2015 à 11:41
Bonjour,

j'ai constitué une macro pour pouvoir rechercher depuis une liste excel des fichiers dans un lecteur, puis une copie de ces fichiers dans un répertoire en dur

Cette macro fonctionne bien sur le lecteur défini en dur, cependant, j'aurai besoin finalement de pouvoir choisir un répertoire ou un lecteur et que la macro balaye tous les répertoires et sous répertoires (si il y en a) depuis le niveau sélectionné.
Par exemple, si je sélectionne le lecteur D: il faut balayer tous les rep et sous rep dessous, par contre si je sélectionne D:\test, il faut balayer D:\test et tous les sous rep qui seraient inclus.

Ci dessous mon code :
Sub dupliean()

Dim P As Range, DosSource$, DosDestin$, ext$, c As Range, DernLigne As Long
DernLigne = Range("A" & Rows.Count).End(xlUp).Row
Set P = Range("A1:A" & DernLigne) 'plage avec les noms des fichiers (sans extension)
DosSource = "Z:\" 'à adapter
DosDestin = "D:\Test\" 'à adapter
ext = ".jpg"
Application.DisplayAlerts = False
On Error Resume Next
MkDir DosDestin 'crée le dossier s'il n'existe pas
For Each c In P
  FileCopy DosSource & c & ext, DosDestin & c & ext
  c(1, 2) = IIf(Dir(DosDestin & c & ext) = "", "", "OK")
Next
MsgBox Application.CountA(P.Offset(, 1)) & " fichiers copiés"
End Sub


J'ai donc besoin de pouvoir choisir DosSource si possible depuis une boite de dialogue type explorer windows

On m'a aidé à créér une fonction :
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
 et du coup dans DosSource, j'ai maintenant = GetFolder("Z:\")
, mais celà ne va pas dans tous les sous repertoires.

Pouvez vous donc m'aider ?

Merci d'avance

EDIT: Ajout de la coloration syntaxique.


pouloucarine

2 réponses

Whismeril Messages postés 17806 Date d'inscription mardi 11 mars 2003 Statut Contributeur Dernière intervention 28 septembre 2022 618
14 févr. 2015 à 11:12
Bonjour, merci de penser à la coloration syntaxique, on l'avait déjà mise pour toi la dernière fois.
0
pouloucarine Messages postés 8 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 26 novembre 2015
14 févr. 2015 à 11:35
merci, je n'avais pas connaissance de celà (un peu béotien sur ce type de forum).
Encore merci, je ferai attention la prochaine fois

pouloucarine
0
ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 236
Modifié par ucfoutu le 14/02/2015 à 11:42
Bonjour,
Regarde ce que fait ceci :
(n'oublie pas d'ajouter une listbox nommée List1 dans cet exemple
Private Sub CommandButton1_Click()
Dim filtredossier As String, filtrefichier As String, repertoire_a_fouiller As String
repertoire_a_fouiller = "d:\monoutil\" ' tu mets ici ton répertoire à fouiller
filtredossier = "modeles" ' tu mets ici le nom de dossier à chercher (si dossier)
' tu mets ensuite le nom de fichier à chercher (si fichier) ... pour toi, ce serait donc
'le même que le nom de dossier, mais avec une extension en plus (tu peux également remlplacer .*
' par .ton_extension, bien entendu
filtrefichier = "*.*"
List1.Clear
fouillons repertoire_a_fouiller, filtredossier, filtrefichier
End Sub

Sub fouillons(ByVal R As String, FD As String, FF As String)
Dim NF As String, NBR As Integer, chemin As String, i As Integer
Me.MousePointer = vbHourglass
If Right$(R, 1) <> "\" Then R = R & "\"
NF = Dir$(R, vbDirectory): NBR = 1
Do While NF <> ""
If NF <> "." And NF <> ".." Then
chemin = R & NF
If GetAttr(chemin) And vbDirectory Then
If NF Like FD Then List1.AddItem chemin
fouillons chemin, FD, FF
NF = Dir$(R, vbDirectory)
For i = 2 To NBR
NF = Dir$
Next
Else
If NF Like FF Then List1.AddItem chemin
End If
End If
NF = Dir$: NBR = NBR + 1
Loop
Me.MousePointer = vbDefault
End Sub



Bien entendu :
- remplace "D\monoutil\" par TON répertoire (celui que te retourne ton sitem
- donne à filtrefichier le filtre que tu souhaites ( ex : "*.*" pour tous, "*.txt" pour les seuls .txt, "*toto*.jpg" pour les seuls .jpg dont le com contient "toto", etc ...
Voilà.
D'aucuns viendront probablement te parler de l'utilisation (plus simple) de FSO. J'émets par avance de très sérieuses réserves à cette utilisation. Pourquoi ? ===>> parce que finalement plus lourd (en mémoire), d'une part, et, d'autre part et surtout : ne marcherait pas sur certaines machines (dont la mienne) dont le propriétaire a inhibé VBS pour des raisons de sécurité.

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviend
0