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 »
