VBA - Excel Déplacer tous types de fichiers
Petite application pour déplacer vos fichiers (quel qu'en soit le type) d'un répertoire « source » vers un répertoire « destination ».
Introduction
Logiciel requis pour cette application : Excel (toutes versions > 97)
Références - Editeur VBE : « Microsoft Scripting Runtime »
Cette procédure utilise une librairie d'objets qui, par défaut, n'est pas incluse dans l'éditeur VBE. Il faut donc ajouter une référence à cette libraire:
- Dans VBE : (pour y accéder, depuis une feuille de calcul de votre classeur Excel, tapez simultanément ALT+F11)
- Menu : Outils
- Choix : Références
- Cochez : « Microsoft Scripting Runtime »
Deux UserForm sont nécessaires, profitez d'être encore sous VBE pour les créer :
Création des UserForm :
- Sous VBE :
- Menu : Insertion
- Choix : UserForm
Les contrôles à insérer :
Dans l'UserForm1 :
- 4 Boutons de Commande, (CommandButton1, CommandButton2, CommandButton3, CommandButton4)
- 2 Labels, en charge d'accueillir les chemins d'accès (Label1, Label2)
- 5 Labels, en charge d'accueillir les noms d'entêtes des colonnes de la Listbox (Label3, Label4, Label5, Label6, Label7)
- 2 CheckBox (CheckBox1 (sélectionner tous les fichiers), CheckBox2(Nouveau répertoire))
- 1 ListBox (ListBox1)
Dans l'UserForm2 :
- 2 Boutons de Commande, (CommandButton1, CommandButton2)
- 1 TextBox (TextBox1)
- 1 Label (facultatif)
L'UserForm1
Code de l'UserForm1
Option Explicit
'---------------------------------------
'Procédure de sélection de tous les fichiers dans la listbox
Private Sub CheckBox1_Click()
Dim i As Long
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = False Then ListBox1.Selected(i) = True
Next i
Else
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then ListBox1.Selected(i) = False
Next i
End If
End Sub
'-------------------------------------
'Montre l'UserForm2 afin de créer un nouveau répertoire
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
UserForm2.Show
End If
End Sub
'--------------------------------------
'Choix du répertoire destination
Private Sub CommandButton2_Click()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If objFolder Is Nothing Then
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
Label2.Caption = objFolder.ParentFolder.ParseName(objFolder.Title).Path
End If
End Sub
'---------------------------------------
'Déplacement des fichiers sélectionnés
Private Sub CommandButton3_Click()
Dim i As Long
Dim source As String, destin As String, message As String
Dim oFSO As Scripting.FileSystemObject
Dim Rep As Integer
message = "Etes-vous sur(e) de vouloir déplacer le(s) fichier(s) sélectionné(s) de : " & vbLf & vbLf & Label1.Caption & vbLf & vbLf & "vers : " & vbLf & vbLf & Label2.Caption
Rep = MsgBox(message, vbYesNo + vbQuestion, "Confirmation")
If Rep = vbYes Then
Set oFSO = New Scripting.FileSystemObject
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
source = Label1.Caption & "\" & ListBox1.List(i)
destin = Label2.Caption & "\" & ListBox1.List(i)
If oFSO.FileExists(source) Then
oFSO.MoveFile source, destin
End If
End If
Next i
ElementsRepertoire Label1.Caption
MsgBox "Déplacement(s) effectué(s).", vbOKOnly + vbInformation, "Fin de traitement"
Else
MsgBox "Abandon opérateur", vbCritical, "Annulation"
End If
End Sub
'--------------------------------------------
'Effacement des contrôles de l'UserForm1
Private Sub CommandButton4_Click()
ListBox1.Clear
Label1.Caption = ""
Label2.Caption = ""
CheckBox1.Value = False
CheckBox2.Value = False
End Sub
'------------------------------------------
'Initialisation de la listbox
Private Sub UserForm_Initialize()
With ListBox1
.ColumnCount = 5
.ColumnWidths = "170;50;60;50;200"
.SetFocus 'inutile, uniquement esthétique
End With
End Sub
'----------------------------------------
'Choix du répertoire source
Private Sub CommandButton1_Click()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If objFolder Is Nothing Then
MsgBox "Abandon opérateur", vbCritical, "Annulation"
End
Else
ElementsRepertoire objFolder.ParentFolder.ParseName(objFolder.Title).Path
End If
End Sub
'-----------------------------------------
'remplissage de la listbox
Private Sub ElementsRepertoire(Chemin As String)
Dim objShell As Object, strFileName As Object
Dim objFolder As Object
Dim NomFic As String, Passe As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(CStr(Chemin))
Label1 = Chemin
ListBox1.Clear
For Each strFileName In objFolder.Items
If strFileName.isFolder = False Then
Passe = Chemin & "\" & strFileName & "*.*"
NomFic = Dir(Passe)
With ListBox1
.AddItem NomFic
.List(ListBox1.ListCount - 1, 1) = objFolder.GetDetailsOf(strFileName, 1)
.List(ListBox1.ListCount - 1, 2) = Format(objFolder.GetDetailsOf(strFileName, 4), "DD/MM/YYYY")
.List(ListBox1.ListCount - 1, 3) = Format(objFolder.GetDetailsOf(strFileName, 3), "DD/MM/YYYY")
.List(ListBox1.ListCount - 1, 4) = objFolder.GetDetailsOf(strFileName, 14)
End With
End If
Next strFileName
End Sub
L'UserForm2
Code de l'UserForm2
Option Explicit
Dim CheminRepParent As String
'-------------------------------------------
'choix du répertoire parent, dans lequel sera créé notre répertoire
Private Sub CommandButton1_Click()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If objFolder Is Nothing Then
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
CheminRepParent = objFolder.ParentFolder.ParseName(objFolder.Title).Path
End If
End Sub
'--------------------------------------------
'Création du répertoire
Private Sub CommandButton2_Click()
Dim oFSO As Scripting.FileSystemObject
Dim oFld As Folder
Dim CheminComplet As String
If TextBox1 = "" Then Exit Sub
Set oFSO = New Scripting.FileSystemObject
CheminComplet = CheminRepParent & "\" & TextBox1
If oFSO.FolderExists(CheminComplet) Then
MsgBox "Ce dossier existe déjà"
Exit Sub
Else
On Error Resume Next
Set oFld = oFSO.CreateFolder(CheminComplet)
End If
UserForm1.Label2.Caption = CheminComplet
UserForm1.CheckBox2.Value = False
Unload Me
End Sub
'----------------------------------------------------
'Empêcher la saisie de caractères interdits ou déconseillés
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If InStr("""!{['^]}/\*?<>|:", Chr(KeyAscii)) <> 0 Then
MsgBox "Caractère interdit ou déconseillé"
KeyAscii = 0
End If
End Sub
'-----------------------------------------------
'vidage du Textbox1
Private Sub UserForm_Initialize()
TextBox1 = ""
End Sub
Exemple d'emploi
Sur une feuille Excel, dessinez un bouton de commande (dans le menu affichage, barre d'outils : Boîte à outils contrôles).
Dans le module de la feuille (pour y accéder : clic droit sur l'onglet de la feuille concernée/Visualiser le code) copiez-collez ce code :
Private Sub CommandButton1_Click()
'Démarrer
UserForm1.Show
End Sub
Téléchargement
Vous pouvez télécharger Le classeur exemple
Si toutefois celui-ci n'est plus disponible sur cjoint, merci de me le faire savoir en m'envoyant un MP ici, cliquez sur « Lui écrire un message »
Ce document intitulé « VBA - Excel Déplacer tous types de fichiers » issu de Comment Ça Marche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.
