Renommage total de noms de fichiers avec incrémentation

Version imprimable

Bonjour à tous,

Je chercher à renommer environ 300 fichiers dans un dossier avec un numéro à incrémenter, et ce peu importe le nom d’origine de chaque fichier, tout doit être remplacé. Un petit exemple :

Fichiers actuels :
Truc.JPG
Bidule.JPG
Machin.JPG
…

Fichiers après renommage :
Bonjour_1.JPG
Bonjour_2.JPG
Bonjour_3.JPG

Et ainsi de suite…

J’ai déjà un super script (trouvé ici, merci encore, je l’utilise régulièrement !), mais qui utilise la fonction Replace. Sauf que comme je ne cherche pas à renommer juste une chaîne de caractères dans les noms de fichiers, mais bien le nom complet, je ne trouve pas comment l’adapter. En plus du fait que j'ai aussi besoin de l'incrémentation :?

Le script en question :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
If AppPrevInstance() Then 
    MsgBox "Attention ! Il ya déjà une instance lancé !" & VbCrLF &_
    CommandLineLike(WScript.ScriptName),VbExclamation,"Attention ! Il ya déjà une instance lancé !"    
    WScript.Quit   
Else 
Dim fso,ws,MonDossier,File,MyNewFile
set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
MonDossier = Parcourir_Dossier()
Set MonDossier = fso.GetFolder(MonDossier)
For each File in MonDossier.Files
    MyNewFile = Replace(File," ","_") '<--------------- Ligne remplacement texte
    MyNewFile = GetNameFile(MyNewFile)
    Call RenameMyFile(File,MyNewFile)
Next
MsgBox "Done !",VbInformation,"L'opération est finie"
ws.run "explorer.exe "& DblQuote(MonDossier)
End If
'*********************************************************************************************
Function Parcourir_Dossier()
    Dim objShell,objFolder,Message
    Message = "Veuillez choisir un dossier :"
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0,Message,1,"C:\Moi\Docs")
    If objFolder Is Nothing Then
        Wscript.Quit
    End If
    Parcourir_Dossier = objFolder.self.path
end Function
'*********************************************************************************************
Function GetNameFile(sFile)
    Dim  Tab
    Tab = Split(sFile,"\")
    GetNameFile = Tab(UBound(Tab))
End Function
'*********************************************************************************************
Sub RenameMyFile(File1,File2)
    Dim Ws,Command,Execution
    Set Ws = CreateObject("WScript.Shell")
    Command = "Cmd /c Rename "& DblQuote(File1) &" "& DblQuote(File2) &""
    Execution = Ws.Run(Command,0,False)
End Sub
'*********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'*********************************************************************************************
Function AppPrevInstance()   
    With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")   
        With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
            " AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")   
            AppPrevInstance = (.Count > 1)
        End With   
    End With   
End Function    
'*********************************************************************************************
Function CommandLineLike(ProcessPath)   
    ProcessPath = Replace(ProcessPath, "\", "\\")   
    CommandLineLike = "'%" & ProcessPath & "%'"   
End Function
'*********************************************************************************************

Merci d’avance pour votre aide :)

Lancer des cmd externe, c'est moche (même masqué).

Voici un code simple, il reste une question en suspend, si le fichier cible (exemple 'Bonjour_2.JPG') existe déjà, que doit il se passer (écrasement, ignore, erreur) ?
Actuellement ce n'est pas récursif (sous-dossier)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 MonDossier="C:\Users\EL227035\Desktop\rename vbs\test" Name = "Bonjour_" Set fso = WScript.CreateObject("Scripting.FileSystemObject") count = 0 For each File in fso.GetFolder(MonDossier).Files count = count + 1 newname = File.ParentFolder & "\" & Name & count if (fso.GetExtensionName(File.Path) <> "") Then newname = newname & "." & fso.GetExtensionName(File.Path) File.Move(newname) Next MsgBox "Done !", VbInformation, "L'opération est finie"

02/08/2016, 14h50
Ysae68

Citation:

Envoyé par ericlm128

Lancer des cmd externe, c'est moche (même masqué).

Comme de toute façon je ne saurais pas faire mieux, du moment que ça marche... :lol:

Et merci beaucoup pour le code, j'ai mes 300 fichiers renommés en quelques secondes, parfait ! :D A propos de la question en suspend, le cas ne se présente pas ici donc je n'ai effectivement pas pensé à préciser ce qui devait se passer si le nom existait déjà.

Petit détail en revanche, j'avais oublié de mettre le underscore à la fin de mon nouveau nom de fichier dans le code (pour reprendre l'exemple, j'avais écris "Bonjour" au lieu de "Bonjour_"), du coup la numérotation des nouveaux noms de fichiers faisait 1, 10, 100, 1000, puis 1001, 1002, 1003... 8O

Merci encore, je vais également le mettre de côté ce script :)
02/08/2016, 15h45
ericlm128

Tu peux très bien les renommer une deuxième fois avec le '_'
02/08/2016, 16h11
Ysae68

Oui bien sur, comme dit mes fichiers ont été renommés comme il faut. Je relevais juste ce point parce que je trouvais cela singulier :)

Bonjour

Pour un parcours récursif et choix d'un dossier à traiter :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Option Explicit 
  Const ForWriting = 2, ForReading = 1, BIF_RETURNONLYFSDIRS = 1
  Const MSG = "Parcours d'un dossier et renommage de ses fichiers"
  Const sName = "Bonjour_"
  Dim oFSO, Idx, F, Verif, sPath, sFile,WS
 
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  sPath = oFSo.GetFolder(SelectFolder).Path
  sFile = sPath & "\Scanned.txt"
  Set Verif = oFSO.OpenTextFile(sFile, ForReading, True)
  Verif.Close  
  'Idx = 1
  ' On vérifie la taille d'un fichier que j'appelerais 'témoin' du renommage
  ' dont la taille devrait faire 60 octets.
    If oFSO.GetFile(sFile).Size > 50  Then 
       MsgBox "Le Dossier " & UCase(sPath) & " a été parcouru." & _
              vbCrLf & "Oprération effectuée : " & oFSO.OpenTextFile(sFile, ForReading).ReadAll & _
              vbCrLf & "On quitte le script sans rien modifier" ,vbInformation
       Wscript.Quit 0
    Else
      ScanFolders sPath
      MsgBox "Opération terminée."
    End If
 
Sub ScanFolders(oFolder)
    Dim oSubFolder
    Idx = 1
 
    For Each F In oFSO.GetFolder(oFolder).Files   
        If Err.Number <> 0 Then
            Err.Clear
        Else
            If F.Name <> "" And  oFSo.GetExtensionName(F.Name) <> "" Then
                F.Name = sName & Right("000" & CStr(Idx), 3) & "." & oFSo.GetExtensionName(F.Name)
                Idx = Idx + 1
            End If
        End If
    Next
    For Each oSubFolder In oFSO.GetFolder(oFolder).SubFolders
        Idx = 1
        If Err.Number <> 0 Then
          Err.Clear
        Else
          ScanFolders oSubFolder
        End If
    Next
    Set Verif = oFSO.OpenTextFile(sFile, ForWriting, True)
    Verif.Write "Dossier parcouru et fichiers renommés le " & Now
    Verif.Close
End Sub
'==============================
Function SelectFolder()
 
Dim WSH, Item, lngFlag, Result, InitDir, DialogTitle, drv, fso
 
    Set WSH = WScript.CreateObject("Shell.Application")
    lngFlag=BIF_returnonlyfsdirs 
    InitDir = "C:"
    DialogTitle="Sélection de dossier :(Pas de Poste de travail, Favoris réseau et/ou ses sous-éléments)"
    Set Item = WSH.BrowseForFolder(0,DialogTitle,lngFlag, "")
    If Item Is Nothing Then WScript.Quit 0
    Set WS = CreateObject("WScript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    If LCase(Item.Title) = "poste de travail" Or LCase(Item.Title) = "favoris réseau" Then 
         MsgBox "Mauvais choix de répertoire [" & UCase(Item.Title) & "]" & VbCrLf & _
                 "Choisir un répertoire valide puis réessayer."
         WScript.Quit 0
    End If
    If LCase(Item.Title) = "mes documents" Or LCase(Item.Title) = "bureau"  Then
         Result = WS.ExpandEnvironmentStrings("%UserProfile%") & "\" & Item.Title
    ElseIf Is_Value(Item) Then
       Result = Item.Title
    ' A-t-on sélectionné la racine d'un lecteur ?
        If Right(Result, 2) = ":)" Then 
            ' Quand il s'agit de la racine d'un lecteur il faut tenir compte de son nom
            ' ( ou Label) qui se présente sous la forme NomLecteur(X:)
            Set drv = fso.GetDrive(Left(Right(Result, 3), 2))
            Result = drv.RootFolder
        ElseIf InStr(1, Result, ":") = 0 Then
            Result = Item.ParentFolder.ParseName(Item.Title).Path
        End If
    End If  
   SelectFolder = Result
End Function
'======================
Function Is_Value(obj)
    Dim stmp
    On Error Resume Next
    stmp = " " & obj
    Is_Value = (Err = 0)
    On Error GoTo 0
End Function

03/08/2016, 13h33
Ysae68

Super, merci d'avoir complété. Je le mets de côté, il me resservira surement :)