'Déclaration des variables dans le haut du module
Option Explicit
Dim Obj As Object
Dim Arr()
Sub A_CopieDesFichiers_Répertoires_Et_Sous_Répertoires()
'Copie les Fichiers d'un Répertoire et de ses Sous Répertoires
Dim RépertoireSource As String, Lextension As Variant
Dim Ok As Boolean, RépertoireDestination As String
Dim SousRep As Boolean
' Choix par boîte de dialogue
Dim DossierA As FileDialog
Dim DossierB As FileDialog
Set DossierA = Application.FileDialog(msoFileDialogFolderPicker)
Set DossierB = Application.FileDialog(msoFileDialogFolderPicker)
With DossierA
.AllowMultiSelect = False
.InitialFileName = "C:\Users\Nom_du_propriétaire_du_compte\Documents\" 'A adapter le chemin
.Title = "Choix du dossier source"
If .Show = -1 Then RépertoireSource = .SelectedItems(1) & "\" Else RépertoireSource = 0
End With
With DossierB
.AllowMultiSelect = False
.InitialFileName = "C:\Users\Nom_du_propriétaire_du_compte\Documents\" 'A adapter le chemin
.Title = "Choix du dossier destination"
If .Show = -1 Then RépertoireDestination = .SelectedItems(1) & "\" Else RépertoireDestination = 0
End With
'********** À adapter éventuellement en cas de non utilisation de boîte de dialogue *****************
'Définir le répertoire Source
'RépertoireSource = "c:\Users\MonNom\Documents\Départ\"
'Définir le répertoire Source
'RépertoireDestination = "c:\Users\MonNom\Documents\Destination\"
'************************************************
'À adapter pour la copie :
'Inclure les fichiers des sous-répertoires : "True"
'exclure les fichiers des sous-répertoires : "False"
SousRep = True
'************************************************
If Dir(RépertoireSource, vbDirectory) = "" Then
MsgBox "Le répertoire source : """ & RépertoireSource & _
""" est introuvable. Opération annulée."
Exit Sub
End If
If Dir(RépertoireDestination, vbDirectory) = "" Then
MsgBox "Le Répertoire de destination : """ & RépertoireDestination & _
""" est introuvable. Opération annulée."
Exit Sub
End If
Ok = False
Do
'Selon les besoins, on peut définir les catégories à
'afficher et les extensions pour chaque type.
Lextension = Application.InputBox( _
"1- Classeurs Excel | 6 = Tous les fichiers" & vbCrLf & _
"2- Documents Word" & vbCrLf & _
"3- Fichiers de musique" & vbCrLf & _
"4- Fichiers texte" & vbCrLf & _
"5- Présentations PowerPoint" & vbCrLf & _
"Insérer LE numéro correspondant.", "Type de fichier à afficher?")
If Val(Lextension) > 0 And Val(Lextension) < 7 Then
Ok = True
Select Case Val(Lextension)
Case Is = 1 'Fichiers Excel
Arr = Array(".xls", ".xlt", ".xlsx", _
".xlsm", ".xla", ".xlam", ".xlb")
Case Is = 2 'Fichiers Word
Arr = Array(".doc", ".dot", ".docx", _
".docm", ".dotm", ".dotx")
Case Is = 3 ' Fichiers de musique
Arr = Array(".mp3", ".wav", ".flac")
Case Is = 4 'Fichiers Texte
Arr = Array(".txt", ".csv", ".rtf")
Case Is = 5 'Fichiers PowerPoint
Arr = Array(".ppt", ".pps", ".ppsx", ".ppsm")
Case Is = 6 'Tous les fichiers
Arr = Array("tous")
End Select
Else
If MsgBox("Votre choix est autre que ceux suggérés." & vbCrLf & _
vbCrLf & "désirez-vous annuler l'opération?", _
vbCritical + vbYesNo, "Attention") = vbYes Then
Exit Sub
End If
End If
Loop Until Ok = True
Set Obj = CreateObject("Scripting.FileSystemObject")
Call CopieDeFichiers(RépertoireSource, RépertoireDestination, SousRep)
End Sub
'-----------------------------------------
Sub CopieDeFichiers(RépertoireSource As String, _
RépertoireDestination As String, _
Inclure_Sous_Répertoires As Boolean)
Dim RepSource As Object, F As Object
Dim SousRepSource As Object, Ext As String
Set RepSource = Obj.getfolder(RépertoireSource)
For Each F In RepSource.Files
Ext = "." & Split(F.Name, ".")(UBound(Split(F.Name, ".")))
If Not IsError(Application.Match(Ext, Arr, 0)) Or Arr(0) = "tous" Then
Obj.CopyFile RepSource.Path & "\" & F.Name, RépertoireDestination, True
End If
Next
If Inclure_Sous_Répertoires Then
For Each SousRepSource In RepSource.SubFolders
Call CopieDeFichiers(SousRepSource.Path, RépertoireDestination, True)
Next
End If
End Sub
