Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Bonsoir Jacques,
OK, je m'en occupe
Salutations
Robert
"Jacques" a écrit dans le message de news:
41f7d34f$0$2156$Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Bonsoir Jacques,
OK, je m'en occupe
Salutations
Robert
"Jacques" <jacques-zeziola@wanadoo.fr> a écrit dans le message de news:
41f7d34f$0$2156$8fcfb975@news.wanadoo.fr...
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Bonsoir Jacques,
OK, je m'en occupe
Salutations
Robert
"Jacques" a écrit dans le message de news:
41f7d34f$0$2156$Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Bonsoir Jacques,
Je t'envoie ci-joint le code modifié du traitement des fichiers pour :
- supprimer les caractères numériques de tête
- remplacer tous les caractères accentués par les équivalents sans accents
- filtre pour extensions de fichiers (à définir)
Pour les dossiers, c'est un peu plus compliqué et je n'aurais peut être pas
le temps de le faire ce soir
Cordiales salutations
Robert
-------------------------------------------------------------------------------
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
' Chemin = "G:TEST CAR"
Extension1 = ".jpeg"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin" comportant l'extension
"Extension1"
For Each Curfic In collfic
If Right(Curfic.Name, Len(Extension1)) = Extension1 Then
n = n + 1
fic(n) = Curfic.Name
End If
Next
' ---- arreter si pas de fichier reconnus
If n = 0 Then
MsgBox "Il n'y a pas de fichiers " & Extension1 & " dans le
répertoire " & Chemin
End
End If
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
newname = oldname
' pour enlever les nombres de tête
' Debug.Print "2) "; newname
For j = 1 To Len(lowname)
' --- arrêt de suppression au 1er caractère alpha
différent de " "
If Left(newname, 1) >= Chr(48) And Left(newname, 1) <=
Chr(57) Or Left(newname, 1) = " " Then
newname = Right(newname, Len(newname) - 1)
End If
Next
' Debug.Print "2) "; newname
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
For j = 1 To Len(newname)
Caract = Mid(newname, j, 1)
z = InStr(1, ListeCar, Caract)
If z <> 0 Then
newname = Replace(newname, Mid(newname, j, 1),
Mid(ListeRem, z, 1))
'Debug.Print j; "-"; Caract; "-"; Mid(ListeRem, z,
1); "-"; newname
End If
Next
'Debug.Print "3) "; newname
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic
End Sub
---------------------------------------------------------------------------------------------
"Jacques" a écrit dans le message de news:
41f7d34f$0$2156$Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Bonsoir Jacques,
Je t'envoie ci-joint le code modifié du traitement des fichiers pour :
- supprimer les caractères numériques de tête
- remplacer tous les caractères accentués par les équivalents sans accents
- filtre pour extensions de fichiers (à définir)
Pour les dossiers, c'est un peu plus compliqué et je n'aurais peut être pas
le temps de le faire ce soir
Cordiales salutations
Robert
-------------------------------------------------------------------------------
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
' Chemin = "G:TEST CAR"
Extension1 = ".jpeg"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin" comportant l'extension
"Extension1"
For Each Curfic In collfic
If Right(Curfic.Name, Len(Extension1)) = Extension1 Then
n = n + 1
fic(n) = Curfic.Name
End If
Next
' ---- arreter si pas de fichier reconnus
If n = 0 Then
MsgBox "Il n'y a pas de fichiers " & Extension1 & " dans le
répertoire " & Chemin
End
End If
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
newname = oldname
' pour enlever les nombres de tête
' Debug.Print "2) "; newname
For j = 1 To Len(lowname)
' --- arrêt de suppression au 1er caractère alpha
différent de " "
If Left(newname, 1) >= Chr(48) And Left(newname, 1) <=
Chr(57) Or Left(newname, 1) = " " Then
newname = Right(newname, Len(newname) - 1)
End If
Next
' Debug.Print "2) "; newname
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
For j = 1 To Len(newname)
Caract = Mid(newname, j, 1)
z = InStr(1, ListeCar, Caract)
If z <> 0 Then
newname = Replace(newname, Mid(newname, j, 1),
Mid(ListeRem, z, 1))
'Debug.Print j; "-"; Caract; "-"; Mid(ListeRem, z,
1); "-"; newname
End If
Next
'Debug.Print "3) "; newname
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic
End Sub
---------------------------------------------------------------------------------------------
"Jacques" <jacques-zeziola@wanadoo.fr> a écrit dans le message de news:
41f7d34f$0$2156$8fcfb975@news.wanadoo.fr...
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Bonsoir Jacques,
Je t'envoie ci-joint le code modifié du traitement des fichiers pour :
- supprimer les caractères numériques de tête
- remplacer tous les caractères accentués par les équivalents sans accents
- filtre pour extensions de fichiers (à définir)
Pour les dossiers, c'est un peu plus compliqué et je n'aurais peut être pas
le temps de le faire ce soir
Cordiales salutations
Robert
-------------------------------------------------------------------------------
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
' Chemin = "G:TEST CAR"
Extension1 = ".jpeg"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin" comportant l'extension
"Extension1"
For Each Curfic In collfic
If Right(Curfic.Name, Len(Extension1)) = Extension1 Then
n = n + 1
fic(n) = Curfic.Name
End If
Next
' ---- arreter si pas de fichier reconnus
If n = 0 Then
MsgBox "Il n'y a pas de fichiers " & Extension1 & " dans le
répertoire " & Chemin
End
End If
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
newname = oldname
' pour enlever les nombres de tête
' Debug.Print "2) "; newname
For j = 1 To Len(lowname)
' --- arrêt de suppression au 1er caractère alpha
différent de " "
If Left(newname, 1) >= Chr(48) And Left(newname, 1) <=
Chr(57) Or Left(newname, 1) = " " Then
newname = Right(newname, Len(newname) - 1)
End If
Next
' Debug.Print "2) "; newname
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
For j = 1 To Len(newname)
Caract = Mid(newname, j, 1)
z = InStr(1, ListeCar, Caract)
If z <> 0 Then
newname = Replace(newname, Mid(newname, j, 1),
Mid(ListeRem, z, 1))
'Debug.Print j; "-"; Caract; "-"; Mid(ListeRem, z,
1); "-"; newname
End If
Next
'Debug.Print "3) "; newname
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic
End Sub
---------------------------------------------------------------------------------------------
"Jacques" a écrit dans le message de news:
41f7d34f$0$2156$Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Merci, de ta patience.
Je ne suis pas pressé d'autant plus que si je devais renommer plus de 2000
photos a la mano j'en aurais pour plus de tant, et si j'aurais tenté moi même
de faire cette macro (Chose d'autant plus incertaine), cela ne serai jamais
fais.
Merci, G'ClaireBonsoir Jacques,
Je t'envoie ci-joint le code modifié du traitement des fichiers pour :
- supprimer les caractères numériques de tête
- remplacer tous les caractères accentués par les équivalents sans accents
- filtre pour extensions de fichiers (à définir)
Pour les dossiers, c'est un peu plus compliqué et je n'aurais peut être pas
le temps de le faire ce soir
Cordiales salutations
Robert
-------------------------------------------------------------------------------
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
' Chemin = "G:TEST CAR"
Extension1 = ".jpeg"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin" comportant l'extension
"Extension1"
For Each Curfic In collfic
If Right(Curfic.Name, Len(Extension1)) = Extension1 Then
n = n + 1
fic(n) = Curfic.Name
End If
Next
' ---- arreter si pas de fichier reconnus
If n = 0 Then
MsgBox "Il n'y a pas de fichiers " & Extension1 & " dans le
répertoire " & Chemin
End
End If
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
newname = oldname
' pour enlever les nombres de tête
' Debug.Print "2) "; newname
For j = 1 To Len(lowname)
' --- arrêt de suppression au 1er caractère alpha
différent de " "
If Left(newname, 1) >= Chr(48) And Left(newname, 1) <=
Chr(57) Or Left(newname, 1) = " " Then
newname = Right(newname, Len(newname) - 1)
End If
Next
' Debug.Print "2) "; newname
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
For j = 1 To Len(newname)
Caract = Mid(newname, j, 1)
z = InStr(1, ListeCar, Caract)
If z <> 0 Then
newname = Replace(newname, Mid(newname, j, 1),
Mid(ListeRem, z, 1))
'Debug.Print j; "-"; Caract; "-"; Mid(ListeRem, z,
1); "-"; newname
End If
Next
'Debug.Print "3) "; newname
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic
End Sub
---------------------------------------------------------------------------------------------
"Jacques" a écrit dans le message de news:
41f7d34f$0$2156$Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Merci, de ta patience.
Je ne suis pas pressé d'autant plus que si je devais renommer plus de 2000
photos a la mano j'en aurais pour plus de tant, et si j'aurais tenté moi même
de faire cette macro (Chose d'autant plus incertaine), cela ne serai jamais
fais.
Merci, G'Claire
Bonsoir Jacques,
Je t'envoie ci-joint le code modifié du traitement des fichiers pour :
- supprimer les caractères numériques de tête
- remplacer tous les caractères accentués par les équivalents sans accents
- filtre pour extensions de fichiers (à définir)
Pour les dossiers, c'est un peu plus compliqué et je n'aurais peut être pas
le temps de le faire ce soir
Cordiales salutations
Robert
-------------------------------------------------------------------------------
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
' Chemin = "G:TEST CAR"
Extension1 = ".jpeg"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin" comportant l'extension
"Extension1"
For Each Curfic In collfic
If Right(Curfic.Name, Len(Extension1)) = Extension1 Then
n = n + 1
fic(n) = Curfic.Name
End If
Next
' ---- arreter si pas de fichier reconnus
If n = 0 Then
MsgBox "Il n'y a pas de fichiers " & Extension1 & " dans le
répertoire " & Chemin
End
End If
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
newname = oldname
' pour enlever les nombres de tête
' Debug.Print "2) "; newname
For j = 1 To Len(lowname)
' --- arrêt de suppression au 1er caractère alpha
différent de " "
If Left(newname, 1) >= Chr(48) And Left(newname, 1) <=
Chr(57) Or Left(newname, 1) = " " Then
newname = Right(newname, Len(newname) - 1)
End If
Next
' Debug.Print "2) "; newname
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
For j = 1 To Len(newname)
Caract = Mid(newname, j, 1)
z = InStr(1, ListeCar, Caract)
If z <> 0 Then
newname = Replace(newname, Mid(newname, j, 1),
Mid(ListeRem, z, 1))
'Debug.Print j; "-"; Caract; "-"; Mid(ListeRem, z,
1); "-"; newname
End If
Next
'Debug.Print "3) "; newname
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic
End Sub
---------------------------------------------------------------------------------------------
"Jacques" <jacques-zeziola@wanadoo.fr> a écrit dans le message de news:
41f7d34f$0$2156$8fcfb975@news.wanadoo.fr...
Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
Herdet, le forum
Merci, de ta patience.
Je ne suis pas pressé d'autant plus que si je devais renommer plus de 2000
photos a la mano j'en aurais pour plus de tant, et si j'aurais tenté moi même
de faire cette macro (Chose d'autant plus incertaine), cela ne serai jamais
fais.
Merci, G'ClaireBonsoir Jacques,
Je t'envoie ci-joint le code modifié du traitement des fichiers pour :
- supprimer les caractères numériques de tête
- remplacer tous les caractères accentués par les équivalents sans accents
- filtre pour extensions de fichiers (à définir)
Pour les dossiers, c'est un peu plus compliqué et je n'aurais peut être pas
le temps de le faire ce soir
Cordiales salutations
Robert
-------------------------------------------------------------------------------
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
' Chemin = "G:TEST CAR"
Extension1 = ".jpeg"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin" comportant l'extension
"Extension1"
For Each Curfic In collfic
If Right(Curfic.Name, Len(Extension1)) = Extension1 Then
n = n + 1
fic(n) = Curfic.Name
End If
Next
' ---- arreter si pas de fichier reconnus
If n = 0 Then
MsgBox "Il n'y a pas de fichiers " & Extension1 & " dans le
répertoire " & Chemin
End
End If
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
newname = oldname
' pour enlever les nombres de tête
' Debug.Print "2) "; newname
For j = 1 To Len(lowname)
' --- arrêt de suppression au 1er caractère alpha
différent de " "
If Left(newname, 1) >= Chr(48) And Left(newname, 1) <=
Chr(57) Or Left(newname, 1) = " " Then
newname = Right(newname, Len(newname) - 1)
End If
Next
' Debug.Print "2) "; newname
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
For j = 1 To Len(newname)
Caract = Mid(newname, j, 1)
z = InStr(1, ListeCar, Caract)
If z <> 0 Then
newname = Replace(newname, Mid(newname, j, 1),
Mid(ListeRem, z, 1))
'Debug.Print j; "-"; Caract; "-"; Mid(ListeRem, z,
1); "-"; newname
End If
Next
'Debug.Print "3) "; newname
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic
End Sub
---------------------------------------------------------------------------------------------
"Jacques" a écrit dans le message de news:
41f7d34f$0$2156$Herdet, le forum
Je repose ma question avec les modifications faite, avec l'aide de Herdet,
car
pour la suppression des chiffres je vais partir du principe que tu a fait
pour la caractères spéciaux, mais j'ai voulu tenté de supprimer la
suppression des chiffres en début de nom (Car si je prends le principe que
si un chiffre rencontré cela le remplace par rien, il n'y en a plus
besoin), mais cela me donne des messages d'erreurs.
Voici ce que j'ai fait (Peu être que le copier coller du code de départ
j'ai eu des ratés, le voici comme je l'ai reconstruit.)
Sub test_rename_fichiers_par_excel()
Dim fic()
' liste des fichiers à l'aide du File Object System (FSO)
Set fso = CreateObject("Scripting.FileSystemObject")
Chemin = "J:aaa-test"
Set folder = fso.GetFolder(Chemin)
Set collfic = folder.Files
tempname = "xxxxx.xxx"
nfic = collfic.Count
ReDim fic(nfic + 1)
n = 0
' tableau des fichiers du répertoire "Chemin"
For Each Curfic In collfic
n = n + 1
fic(n) = Curfic.Name
Next
' ajout d'un en fin de Chemin
If Right(Chemin, 1) <> "" Then
Chemin = Chemin & ""
n = 0
For i = 1 To nfic
oldname = fic(i)
Set Curfic = fso.GetFile(Chemin & oldname)
lowname = LCase(oldname)
' ----- actions sur le nouveau nom de fichier
newname = Right(oldname, Len(oldname) - 3)
' pour enlever les 5 caractères de tête
newname = Replace(newname, "é", "e", 1)
newname = Replace(newname, "è", "e", 1)
newname = Replace(newname, "0", "", 1)
newname = Replace(newname, "1", "", 1)
newname = Replace(newname, "2", "", 1)
newname = Replace(newname, "3", "", 1)
newname = Replace(newname, "4", "", 1)
newname = Replace(newname, "5", "", 1)
newname = Replace(newname, "6", "", 1)
newname = Replace(newname, "7", "", 1)
newname = Replace(newname, "8", "", 1)
newname = Replace(newname, "9", "", 1)
' renommer le fichier avec newname
If newname <> lowname Then
n = n + 1
newfic = Chemin & newname
If fso.FileExists(newfic) Then
fso.DeleteFile newfic, True
End If
Curfic.Name = tempname
Curfic.Name = newname
End If
Next i
End If
MsgBox n & " fichiers renommés", vbOKOnly, "Renommage de fichiers dans " &
Curfic 'End
End Sub
Par-contre je n'arrive pas a le faire avec des sous-dossiers et juste pour
des fichiers jpeg
Pour tous ces caractères, y'a t-il toujours une corespondance comme ici le
"é" par le "e", si oui comme cela je prévoirai pour les prochains.
Je me doute que par exemple il y aura le "à" a remplacer par le "a" le "ù"
par le "u"...etc
Si tu as une peu de temps, je t'en serai reconnaissant, G'Claire
