classer des fichiers d'un répertoire

Version imprimable

Bonjour,
mon répertoire contient des centaines de jpg nommés de la façon suivante:
fichier 001-1
fichier 001-2
..
fichier 001-100
...
fichier 200-1
fichier 200-2
...
fichier 200-100

Je souhaite trier ces fichiers et créer des répertoires contenant les fichiers correspondants à chaque groupe:
[fichier 001]
fichier 001-1
fichier 001-2
...
fichier 001-100

[fichier 200]
fichier 200-1
fichier 200-2
...
fichier 200-100

c'est mon 1er script en vbs. j'ai essayé d'adapter un code existant mais rien ne se passe. Si quelqu'un peut m'aider, je suis preneur !! Merci d'avance.

cf ci-dessous mon bout de code

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
Sub trifichier()
    Dim Fso 
    Dim origin : origin ="F:\origin\" 
	Dim fichier : fichier = ".jpg"
    Dim destin : destin = "F:\destin"
 
	'Pour accéder aux fichiers, aux répertoires et aux volumes gérés par Windows,
	Set Fso = CreateObject("Scripting.FileSystemObject")
    If Fso.FolderExists(destin) = False Then Exit Sub
 
	'Pour avoir accès aux fichiers d'un répertoire, on peut d'abord accéder à un objet Folder (pour le répertoire visé) 
	Set origin = Fso.GetFolder(destin)
            For Each fichier In origin
            If Fso.FolderExists(origin & "\" & UCase(Mid(fichier, InStrRev(fichier, ".") - 15, 3))) = True Then  
		    Fso.MoveFile fichier, origin & "\" & UCase(Mid(fichier, InStrRev(fichier, ".") - 15, 3)) & "\" & fichier 
	Else
	'CreateFolder: Créer un nouvel objet
	'Ucase : Convertit la chaîne string en majuscules.
	'Mid : Renvoie un nombre spécifié (length) de caractère à partir d'une chaîne de caractères (string). 
	'InStrRev : Renvoie la position de la 1ere occurence d'une chaîne de caractères (string2) dans une autre (string1), en commençant par la fin 
	Set destin = Fso.CreateFolder(origin & "\" & UCase(Mid(fichier, InStrRev(fichier, ".") - 15, 3)))
            Fso.MoveFile fichier, destin & "\" & fichier
        End If
    Next
 End Sub

Dans ton script, il y a un mélange de termes qui indiquent en même temps une chaine de caractères et un objet.

D'autre part, si tu codes une fonction ou Sub que tu n'appelles pas, aucune action n'est faite quand tu exécute le script.

Voici une esquisse de ce qu'on devrait faire :

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
Option Explicit
 
Call TriFichiers ' appel de la Sub
 
Sub TriFichiers()
    Dim fso, strNumFolder 
    Dim origin : origin ="F:\origin" 
    Dim destin : destin = "F:\destin"
    Dim DestFold, SrcFolder
    Dim BaseName, fichier 
    'Pour accéder aux fichiers, aux répertoires et aux volumes gérés par Windows,
    Set Fso = CreateObject("Scripting.FileSystemObject")
    If Not Fso.FolderExists(destin)  Then fso.CreateFolder(destin)
 
    'Pour avoir accès aux fichiers d'un répertoire, on peut d'abord accéder à un objet Folder (pour le répertoire visé) 
    Set SrcFolder = Fso.GetFolder(origin)
        For Each fichier In SrcFolder.Files
            BaseName = Left(fso.GetBaseName(fichier), 11) ' ce qui correspond à "fichier 001" par exemple
            strNumFolder = Split(BaseName, " ")(1) ' ceci correspond au nombre juste avant le signe -
            If Fso.FolderExists(destin & "\fichier " & strNumFolder) Then  
                If InStr(1, Lcase(fichier.Name), "fichier " & strNumFolder ) > 0 Then _ 
                    Fso.MoveFile fichier.Path, destin & "\fichier " & strNumFolder & "\" 
            Else
                Set DestFold = Fso.CreateFolder(destin & "\fichier " & strNumFolder)
                Fso.MoveFile fichier.Path, DestFold.Path & "\" 
            End If
        Next
 End Sub

01/04/2017, 23h05
fcka0001

classer des fichiers d'un répertoire

bonsoir et merci l_autodidacte

le script fonctionne en partie

Je m'explique :
tous les répertoires "fichier 001", "fichier 002", ... sont bien créés, mais un seul jpg est déplacé dans chacun d'eux.

le répertoire "fichier 001" contient que le 1er jpg du répertoire 001.
le répertoire "fichier 002" contient que le 1er jpg du répertoire 002.

c'est encourageant, je continue
fcka

J'ai testé le code et il fonctionne sans problème.

Peut-être faut-il ajouter une condition sur le nom du fichier quand un répertoire est créé ? soit par exemple :

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
 
Call TriFichiers ' appel de la Sub
 
Sub TriFichiers()
    Dim fso, strNumFolder 
    Dim origin : origin ="F:\origin" 
    Dim destin : destin = "F:\destin"
    Dim DestFold, SrcFolder
    Dim BaseName, fichier 
    'Pour accéder aux fichiers, aux répertoires et aux volumes gérés par Windows,
    Set Fso = CreateObject("Scripting.FileSystemObject")
    If Not Fso.FolderExists(destin)  Then fso.CreateFolder(destin)
 
    'Pour avoir accès aux fichiers d'un répertoire, on peut d'abord accéder à un objet Folder (pour le répertoire visé) 
    Set SrcFolder = Fso.GetFolder(origin)
        For Each fichier In SrcFolder.Files
            BaseName = Left(fso.GetBaseName(fichier), 11) ' ce qui correspond à "fichier 001" par exemple
            strNumFolder = Split(BaseName, " ")(1) ' ceci correspond au nombre juste avant le signe -
            If Fso.FolderExists(destin & "\fichier " & strNumFolder) Then  
                If InStr(1, Lcase(fichier.Name), "fichier " & strNumFolder ) > 0 Then _ 
                    Fso.MoveFile fichier.Path, destin & "\fichier " & strNumFolder & "\" 
            Else
                Set DestFold = Fso.CreateFolder(destin & "\fichier " & strNumFolder)
             ' Ici la condition ajoutée :
                If InStr(1, Lcase(fichier.Name), "fichier " & strNumFolder ) > 0 Then _ 
                    Fso.MoveFile fichier.Path, DestFold.Path & "\" 
            End If
        Next
 End Sub

02/04/2017, 01h28
fcka0001

classer des fichiers d'un répertoire

Bonsoir
J'ai testé en renommant mes fichiers et cela fonctionne parfaitement.

Le problème venait "du nom" de mes fichiers. que j'avais simplifié dans ma question.

En réalité, ils sont nommés comme cela:
photogra j001_prise132_image1.jpg
photogra j001_prise132_image2.jpg
...
photogra j200_prise132_image1.jpg
photogra j200_prise132_image2.jpg

en tout cas, :merci:
fcka