Copie de fichiers vers dossiers en fonction du nom de fichier

Version imprimable

27/10/2015, 15h30
zeuch

Copie de fichiers vers dossiers en fonction du nom de fichier

Bonjour,

Je cherche à copier une liste de fichiers qui sont tous dans un même dossier vers des dossiers différents.

Les noms des fichiers sont composées ainsi:
[N° de 4 à 6 caractères]-[Date au format AAAAMMJJ]-[N° de 1 à 4].extension

Exemples :

2788-20150909-1
12345-20150909-2
265478-20150909-4

Je voudrais pouvoir copier ces fichiers dans des dossiers (existants ou non) nommés comme le code avant le premier tiret

Exemple:

2788-20150909-1 --> copié dans dossier nommé "2788"
12345-20150909-2 --> copié dans dossier nommé "12345"
265478-20150909-4 --> copié dans dossier nommé "265478"

Malheureusement ça dépasse un peu (beaucoup :)) mes compétences en script...

Merci d'avance !

:salut:
Peut-être une solution en Vbscript :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
Dim File,MyRootFolder,RootFolder
MyRootFolder = Browse4Folder
Call Scan4File(MyRootFolder)
MsgBox "Script Done !",VbInformation,"Script Done !"
'**************************************************************************
Function Browse4Folder()
    Dim objShell,objFolder,Message
    Message = "Please select a folder "
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0,Message,0,0)
    If objFolder Is Nothing Then
        Wscript.Quit
    End If
    Browse4Folder = objFolder.self.path
End Function
'****************************************************************************
Function Scan4File(Folder)
    Dim fso,objFolder,FileName
    Dim Tab,aFile,NewFolderName
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(Folder)
    For Each FileName in objFolder.Files
        Tab = Split(FileName,"-")
        NewFolderName = Tab(0)
        Msgbox NewFolderName
        BuildFullPath(NewFolderName)
        Set aFile = fso.GetFile(FileName)
        aFile.Copy NewFolderName & "\"    
    Next
End Function
'*****************************************************************************
Sub BuildFullPath(ByVal FullPath)
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(FullPath) Then
        BuildFullPath fso.GetParentFolderName(FullPath)
        fso.CreateFolder FullPath
    End If
End Sub
'*****************************************************************************

Merci pour ta réponse c'est super!

J'ai adapté (avec mes maigres connaissances) pour rentrer en dur le chemin d'origine (c:\temp) de mes fichiers.
Par contre je ne sais pas comment je peux mettre en dur un chemin de destination :(

une petite idée ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Option Explicit
Dim File,MyRootFolder,RootFolder
MyRootFolder = Browse4Folder
Call Scan4File(MyRootFolder)
MsgBox "Script Done !",VbInformation,"Script Done !"
'**************************************************************************
Function Browse4Folder()
	Dim objFolder
	Dim objShell
    'Dim objShell,objFolder,Message
    'Message = "Please select a folder "
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.NameSpace("c:\temp")
    If objFolder Is Nothing Then
    Wscript.Quit
    End If
    Browse4Folder = objFolder.self.path
End Function
'****************************************************************************
Function Scan4File(Folder)
    Dim fso,objFolder,FileName
    Dim Tab,aFile,NewFolderName
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(Folder)
    For Each FileName in objFolder.Files
        Tab = Split(FileName,"-")
        NewFolderName = Tab(0)
        'Msgbox NewFolderName
        BuildFullPath(NewFolderName)
        Set aFile = fso.GetFile(FileName)
        aFile.Copy NewFolderName & "\"    
    Next
End Function
'*****************************************************************************
Sub BuildFullPath(ByVal FullPath)
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(FullPath) Then
        BuildFullPath fso.GetParentFolderName(FullPath)
        fso.CreateFolder FullPath
    End If
End Sub
'*****************************************************************************

Like this way ;)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Explicit
Dim File,MyRootFolder
MyRootFolder = "c:\temp"
Call Scan4File(MyRootFolder)
MsgBox "Script Done !",VbInformation,"Script Done !"
'****************************************************************************
Function Scan4File(Folder)
    Dim fso,objFolder,FileName
    Dim Tab,aFile,NewFolderName
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(Folder)
    For Each FileName in objFolder.Files
        Tab = Split(FileName,"-")
        NewFolderName = Tab(0)
        Msgbox NewFolderName
        BuildFullPath(NewFolderName)
        Set aFile = fso.GetFile(FileName)
        aFile.Copy NewFolderName & "\"    
    Next
End Function
'*****************************************************************************
Sub BuildFullPath(ByVal FullPath)
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(FullPath) Then
        BuildFullPath fso.GetParentFolderName(FullPath)
        fso.CreateFolder FullPath
    End If
End Sub
'*****************************************************************************

28/10/2015, 16h58
zeuch

Merci mais comment puis-je choisir le dossier de destination où seront copiés les fichiers ? Je m'explique:

Pour l'instant les fichiers sont copiés dans des dossiers avec le code présent dans le nom de fichier (super) mais ces dossiers sont dans c:\temp

Exemple:

c:\temp\1290\[fichier]

J'aimerais que les dossiers soient dans C:\result\1290\[fichier] par exemple.

Comment puis je faire ça ?

Merci!

Citation:

Envoyé par zeuch

Merci mais comment puis-je choisir le dossier de destination où seront copiés les fichiers ? Je m'explique:
Pour l'instant les fichiers sont copiés dans des dossiers avec le code présent dans le nom de fichier (super) mais ces dossiers sont dans c:\temp
Exemple:
c:\temp\1290\[fichier]
J'aimerais que les dossiers soient dans C:\result\1290\[fichier] par exemple.
Comment puis je faire ça ?
Merci!

Voulez-vous dire comme ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Option Explicit
Dim File,SourceFolder,DestinationFolder
SourceFolder = "C:\temp"
DestinationFolder = "C:\result"
Call Scan4File(SourceFolder)
MsgBox "Script Done !",VbInformation,"Script Done !"
'****************************************************************************
Function Scan4File(Folder)
    Dim fso,objFolder,File
    Dim Tab,aFile,NewFolderName
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(Folder)
    For Each File in objFolder.Files
        Tab = Split(File.Name,"-")
        NewFolderName = Tab(0)
        Msgbox DestinationFolder & "\" & NewFolderName
        BuildFullPath(DestinationFolder & "\" & NewFolderName)
        Set aFile = fso.GetFile(File)
        aFile.Copy DestinationFolder & "\" & NewFolderName & "\"    
    Next
End Function
'*****************************************************************************
Sub BuildFullPath(ByVal FullPath)
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(FullPath) Then
        BuildFullPath fso.GetParentFolderName(FullPath)
        fso.CreateFolder FullPath
    End If
End Sub
'*****************************************************************************

28/10/2015, 22h29
zeuch

C'est parfait!

Juste un dernier point si vous pouvez encore me consacrer un peu de votre temps:

Serait il possible de faire un filtre sur l'extension du fichier ?

Par exemple ne copier que les fichiers ayant l'extension .pdf

Citation:

Envoyé par zeuch

C'est parfait!
Juste un dernier point si vous pouvez encore me consacrer un peu de votre temps:
Serait il possible de faire un filtre sur l'extension du fichier ?
Par exemple ne copier que les fichiers ayant l'extension .pdf

:salut:
Ajout du filtre sur l'extension du type PDF :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
Dim File,SourceFolder,DestinationFolder,Ws
SourceFolder = "C:\temp"
DestinationFolder = "C:\result"
Call Scan4File(SourceFolder)
MsgBox "Le script est terminé by Hackoo !",VbInformation,"Script est terminé by Hackoo !"
Set Ws = CreateObject("wscript.shell")
ws.run "Explorer " & DblQuote(DestinationFolder)
'*********************************************************************
Function Scan4File(Folder)
    Dim fso,objFolder,File
    Dim Tab,aFile,NewFolderName
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(Folder)
    For Each File in objFolder.Files
        'Pour filtrer juste les fichiers PDF
        If UCase(fso.GetExtensionName(File)) = "PDF" Then
            Tab = Split(File.Name,"-")
            NewFolderName = Tab(0)
            BuildFullPath(DestinationFolder & "\" & NewFolderName)
            Set aFile = fso.GetFile(File)
            aFile.Copy DestinationFolder & "\" & NewFolderName & "\"
            Msgbox "Le fichier " & DblQuote(File) & " est copié dans " & vbcr &_
            DblQuote(DestinationFolder & "\" & NewFolderName),vbInformation,DblQuote(File)
        End If        
    Next
End Function
'*********************************************************************
Sub BuildFullPath(ByVal FullPath)
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FullPath) Then
    BuildFullPath fso.GetParentFolderName(FullPath)
    fso.CreateFolder FullPath
End If
End Sub
'*********************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'*********************************************************************

J'attends mes +1 :plusser: et n'oubliez pas aussi de passer cette discussion en :resolu: :mouarf: