' ----------------------------------------------------------
' 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)
' JC BELLAMY © 2002 modifé en 2007 : 
'	récursivité
'	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, folder, collfic,curfic
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_ROOT\Folder\shell\Sansaccents\"
	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"
	wscript.quit
	End If
nd=0
nf=0
Rename curdir
MsgBox nd & " dossier" & pluriel(nd) & " et " & nf & _
	" fichier"  & pluriel(nf) & " renommé" & pluriel(nd+nf) & " sans accent",, _
	"Renommage dans " & Curdir
'--------------------------------------------------------------------
Sub Rename(curdir)
DT=replace(FormatDateTime(now, vbGeneralDate),"/", "-")
DT=replace(DT,":","-")
tempname="tmp" & DT
set folder=fso.GetFolder(curdir)
If not folder.IsRootFolder Then
	set parent=folder.ParentFolder
	parentpath=parent.path
	oldname=folder.Name
	newname=Sansacc(oldname)
	If StrComp(newname,oldname,vbTextCompare)<>0 Then
		Suffix=""
		num=0
		Do
			fullname=parentpath & "\" & newname & suffix
			exist=fso.FolderExists(fullname) 
			If exist Then
				num=num+1
				suffix=CStr(num)
				End If
			Loop Until not exist
		on error resume next
		folder.Name=tempname
		If err<>0 Then
			wscript.echo "erreur pour renommer le dossier " & oldname & " en " & tempname
		else
			folder.Name=newname & suffix
			If err=0 Then
				nd=nd+1
				wscript.echo "dossier " & oldname & " renommé en " & newname & suffix
            else 
				wscript.echo "erreur pour renommer le dossier " & oldname & " en " & newname & suffix
				folder.Name=oldname
				end if
			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(oldname)
	If StrComp(newname,oldname,vbTextCompare)<>0 Then
		Suffix=""
		num=0
		Do
			fullname=parentpath & "\" & newname & suffix
			exist=fso.FileExists(fullname)
			If exist Then
				num=num+1
				suffix=CStr(num)
				End If
			Loop Until not exist
		on error resume next
		CurFic.Name=tempname
		If err<>0 Then
			wscript.echo "erreur pour renommer le fichier " & oldname & " en " & tempname
		Else
			CurFic.Name=newname & suffix
			If err=0 Then	
				nf=nf+1
				wscript.echo "fichier " & oldname & " renommé en " & newname & suffix
			else 
				CurFic.Name=oldname
				wscript.echo "erreur pour renommer le fichier " & oldname & " en " & newname & suffix
				end if
			End If
		err.clear
		on error goto 0
		End If
	next
End Sub
'--------------------------------------------------------------------
Function Sansacc(oldname)
lowname=lcase(oldname)
l=len(lowname)
newname=""
For j = 1 To l
	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
	newname=newname & car
	Next
Sansacc=newname
End Function
'--------------------------------------------------------------------
Function pluriel(n)
If n<=1 Then pluriel="" else pluriel="s"
End Function