modification par lot des noms de fichiers

Jean-Claude BELLAMY a écrit :

"Michel__D" <Michel.NOSPAM@orange-ft.com.invalid> a écrit dans le
message de groupe de discussion : i3u85q$f7o$1@speranza.aioe.org...

g.bon a écrit :

Merci, c'est vraiment impeccable.

Une petite constatation en revanche, juste pour info.
Sur ma machine (Vista 64) le script a un comportement un peu étrange
lorsqu'on est en présence de sous-répertoires.
En effet, il ne traite que les arborescences les plus profondes.

Par exemple, si j'ai des fichiers à renommer dans chacun des dossiers
suivants :
temp
tempA_niv2
tempB_niv2
tempB_niv2B_niv3

Seuls seront traités les fichiers dans :
tempA_niv2
tempB_niv2B_niv3

Oui il y a un bug dans le traitement récursif, je te propose
le script ci-dessous légérement remanié
[...]

Merci Michel !
Sympa !
Ça c'est de la "source vraiment ouverte" !! ;-)

Je vais mettre à jour le script sur mon site (avec tes modifs et
annotations, oeuf corse!)

Pas de problème, par contre on peut encore optimiser/corriger :

' ----------------------------------------------------------
' Script VBS de renommage sans accent de fichiers ou dossiers
' contenus dans un dossier (depuis l'explorateur)
' Auto-installable (par exécution sans paramètres)
' Sur la base du script de JC BELLAMY © 2002 modifé en 2010 par MD :
' correction d'un bug dans la récursivité et légère réécriture du code
' modification de noms de dossiers
' Si le nom sans accent existe déjà, un suffixe numérique
' autoincrémenté est ajouté au nom.
' ----------------------------------------------------------
Dim shell, args, fso, collfic, curfic, modif
Set args = Wscript.Arguments
Set shell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If args.count=0 Then
' Auto-installation
Script=Wscript.ScriptFullName
Key="HKEY_CLASSES_ROOTFoldershellSansaccents"
shell.RegWrite Key,"Renommage des fichiers sans accent"
Command="cscript """ & Script & """ ""%1"""
shell.RegWrite Key & "command",Command
MsgBox "Script "& Script &" installé", vbInformation, "Renommage de fichiers sans accent"
wscript.quit
end if
curdir=args(0)
If not fso.FolderExists(curdir) Then
wscript.echo "Répertoire inexistant"
MsgBox "Répertoire inexistant" & vbcrlf & Curdir
wscript.quit
End If
nd=0
nf=0
Rename curdir
MsgBox nd & " dossier(s) et " & nf & " fichier(s) renommé(s) sans accent",, _
"Renommage dans " & Curdir
' --------------------------------------------------------------------
Sub Rename(curdir)
Dim folder

set folder=fso.GetFolder(curdir)
If not folder.IsRootFolder Then
set parent=folder.ParentFolder
newname=Sansacc(parent.path,folder.Name)
If modif<>0 Then
on error resume next
folder.Name=newname
If err<>0 Then
wscript.echo "erreur pour renommer le dossier " & oldname & " en " & newname
Else
nd=nd+1
wscript.echo "dossier " & oldname & " renommé en " & newname
End If
err.clear
on error goto 0
End If
End If
set colldir=folder.SubFolders
For each cursubdir in colldir
Rename cursubdir.Path
Next

parentpath=folder.Path
set collfic=folder.Files
For each Curfic in collfic
newname=Sansacc(parentpath,CurFic.Name)
If modif<>0 Then
on error resume next
CurFic.Name=newname
If err<>0 Then
wscript.echo "erreur pour renommer le fichier " & oldname & " en " & newname
Else
nf=nf+1
wscript.echo "fichier " & oldname & " renommé en " & newname
End If
err.clear
on error goto 0
End If
next
End Sub
' --------------------------------------------------------------------
Function Sansacc(parentpath,oldname)
lowname=lcase(oldname)
l=len(lowname)
newname=""
suffix=""
modif=0
For j = 1 To l
car=""
c=Mid(lowname,j,1)
Select Case c
Case "à", "â", "ä", "á","æ"
car="a"
Case "é", "è", "ê", "ë"
car="e"
Case "î","ï"
car="i"
Case "ô","ö"
car="o"
Case "û", "ü", "ù"
car="u"
Case "ÿ"
car="y"
Case "ç"
car="c"
Case "ñ"
car="n"
End Select
modif=modif Or len(car)
If len(car)=0 Then car=c
newname=newname & car
Next
if modif<>0 Then
fullname=parentpath & "" & newname
num=0
Do
etat=num
If fso.FileExists(fullname & suffix) Then
num=num+1
suffix=CStr(num)
End If
If fso.FolderExists(fullname & suffix) Then
num=num+1
suffix=CStr(num)
End If
Loop until num=etat
End If
Sansacc=newname & suffix
End Function
' --------------------------------------------------------------------

Michel__D a écrit :

Jean-Claude BELLAMY a écrit :

"Michel__D" <Michel.NOSPAM@orange-ft.com.invalid> a écrit dans le
message de groupe de discussion : i3u85q$f7o$1@speranza.aioe.org...

g.bon a écrit :

Merci, c'est vraiment impeccable.

Une petite constatation en revanche, juste pour info.
Sur ma machine (Vista 64) le script a un comportement un peu étrange
lorsqu'on est en présence de sous-répertoires.
En effet, il ne traite que les arborescences les plus profondes.

Par exemple, si j'ai des fichiers à renommer dans chacun des
dossiers suivants :
temp
tempA_niv2
tempB_niv2
tempB_niv2B_niv3

Seuls seront traités les fichiers dans :
tempA_niv2
tempB_niv2B_niv3

Oui il y a un bug dans le traitement récursif, je te propose
le script ci-dessous légérement remanié
[...]

Merci Michel !
Sympa !
Ça c'est de la "source vraiment ouverte" !! ;-)

Je vais mettre à jour le script sur mon site (avec tes modifs et
annotations, oeuf corse!)

Bon je me suis un peu emporté avec le script précédent !

' -----------------------------------------------------------
' Script VBS de renommage sans accent de fichiers ou dossiers
' contenus dans un dossier (depuis l'explorateur)
' Auto-installable (par exécution sans paramètres)
' Sur la base du script de JC BELLAMY © 2002 modifé en 2010 par MD :
' correction d'un bug dans la récursivité et légère réécriture du code
' modification de noms de dossiers
' Si le nom sans accent existe déjà, un suffixe numérique
' autoincrémenté est ajouté au nom.
' -----------------------------------------------------------
Dim shell, args, fso, collfic, curfic, modif
Set args = Wscript.Arguments
Set shell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If args.count=0 Then
' Auto-installation
Script=Wscript.ScriptFullName
Key="HKEY_CLASSES_ROOTFoldershellSansaccents"
shell.RegWrite Key,"Renommage des fichiers sans accent"
Command="cscript """ & Script & """ ""%1"""
shell.RegWrite Key & "command",Command
MsgBox "Script "& Script &" installé", vbInformation, "Renommage de fichiers sans accent"
wscript.quit
end if
curdir=args(0)
If not fso.FolderExists(curdir) Then
wscript.echo "Répertoire inexistant"
MsgBox "Répertoire inexistant" & vbcrlf & Curdir
wscript.quit
End If
nd=0
nf=0
Rename curdir
MsgBox nd & " dossier(s) et " & nf & " fichier(s) renommé(s) sans accent",, _
"Renommage dans " & Curdir
' --------------------------------------------------------------------
Sub Rename(curdir)
Dim folder

set folder=fso.GetFolder(curdir)
If not folder.IsRootFolder Then
set parent=folder.ParentFolder
oldname=folder.Name
newname=Sansacc(parent.path,oldname)
If modif<>0 Then
on error resume next
folder.Name=newname
If err<>0 Then
wscript.echo "erreur pour renommer le dossier " & oldname & " en " & newname
Else
nd=nd+1
wscript.echo "dossier " & oldname & " renommé en " & newname
End If
err.clear
on error goto 0
End If
End If
set colldir=folder.SubFolders
For each cursubdir in colldir
Rename cursubdir.Path
Next

parentpath=folder.Path
set collfic=folder.Files
For each Curfic in collfic
oldname=CurFic.Name
newname=Sansacc(parentpath,oldname)
If modif<>0 Then
on error resume next
CurFic.Name=newname
If err<>0 Then
wscript.echo "erreur pour renommer le fichier " & oldname & " en " & newname
Else
nf=nf+1
wscript.echo "fichier " & oldname & " renommé en " & newname
End If
err.clear
on error goto 0
End If
next
End Sub
' --------------------------------------------------------------------
Function Sansacc(parentpath,oldname)
lowname=lcase(oldname)
l=len(lowname)
newname=""
suffix=""
modif=0
For j = 1 To l
car=""
c=Mid(lowname,j,1)
Select Case c
Case "à", "â", "ä", "á","æ"
car="a"
Case "é", "è", "ê", "ë"
car="e"
Case "î","ï"
car="i"
Case "ô","ö"
car="o"
Case "û", "ü", "ù"
car="u"
Case "ÿ"
car="y"
Case "ç"
car="c"
Case "ñ"
car="n"
Case Else
car=c
End Select
modif=modif Or (asc(car) xor asc(c))
newname=newname & car
Next
if modif<>0 Then
fullname=parentpath & "" & newname
num=0
Do
etat=num
If fso.FileExists(fullname & suffix) Then
num=num+1
suffix=CStr(num)
End If
If fso.FolderExists(fullname & suffix) Then
num=num+1
suffix=CStr(num)
End If
Loop until num=etat
End If
Sansacc=newname & suffix
End Function
' --------------------------------------------------------------------