Excel/VBA - Move all types of files

February 2017


Excel/VBA - Move all types of files



Small application to move your files (whatever the type) from a "Source" to "Destination" directory.

Introduction


Software required for this application: Excel (all versions> 97)

References - VBE editor: "Microsoft Scripting Runtime"
This procedure uses a library of objects which by default is not included in the VBE editor. We must therefore add a reference to this library:
Open VBE: (to access it from a worksheet of your Excel workbook, press ALT + F11 simultaneously)
  • Menu: Tools
  • Choice: References
  • Select "Microsoft Scripting Runtime"



Two UserForm will be needed:
  • In VBE:
  • Menu: Insert
  • Choice: UserForm



The controls include:

In UserForm1:
- 4 command buttons, (CommandButton1, CommandButton2, CommandButton3, CommandButton4)
- 2 Labels, to host the paths (Label1, Label2)
- 5 Labels, to host the names of the column headers of the Listbox (Label3, Label4, Label5, Label6, Label7)
- 2 CheckBox (CheckBox1 (select all files), CheckBox2 (New directory))
- A ListBox (ListBox1)

In UserForm2:
- 2 command keys (CommandButton1, CommandButton2)
- 1 TextBox (TextBox1)
- Label 1 (optional)

The 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

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

Example of use


On an Excel spreadsheet, draw a command button ( View menu, toolbar: Toolkit controls).
In the module of the sheet (to access it: Right-click the sheet tab > View Code) copy and paste this code:
Private Sub CommandButton1_Click()    
'Démarrer
UserForm1.Show
End Sub

Download the sample workbook


You can download the sample workbook: here

Related


Published by deri58. Latest update on April 3, 2014 at 08:38 AM by deri58.
This document, titled "Excel/VBA - Move all types of files," is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).