Suite : Renommer photos suivants critères

Herdet le forum

Je suis désolé, mais je n'arrive pas a faire fonctionner ta macro.

Cela me met directement 0 fichier renomés, même si dans le dossier d'origine.

Es-ce du au copier /collé que j'ai mal refait ou du fait que je suis sous
excel 2000?

Merci, pour ton aide, G'Claire

Bonsoir à tous,
Je relance un nouveau fil sur le sujet car mon dernier post est déjà perdu
depuis 3 jours !!!

A l'attention de G'Claire (Jacques ??)
Je ne sais pas si il est possible de récupérer en une seule commande les
noms de tous les fichiers d'un répertoire et de ses sous-répertoires car il
faut appliquer une fonction récursive sur le répertoire principal.
NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous les
fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
efficace.
Tu trouveras ci-après une amélioration de mon dernier code ( à copier dans
un module) pour renommer tous les fichiers d'un répertoire et de ses
sous-répertoires

Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent les
données et résultats dans les colonnes A et B de la feuille active.
J'ai laissé tomber l'utilisation du File Object System (FSO) car la fonction
Name fait le même boulot (Office Pro Excel 2002)
Pour utiliser un filtre sur plusieurs extensions tu peux :
- ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
- remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2 Or
Ext = Extension3 Then

En étant un peu ambitieux,on peut aussi améliorer la sélection du répertoire
à traiter en utilisant la fonction GetDirectory
Et en ajoutant une boite de dialogue avec la saisie de quelques paramètres
(texte commun aux photos, préfixes, suffixes, etc...), une sélection
multiple dans une liste d'extensions et pourquoi pas une petite visionneuse,
ce bout de code deviendrait une vrai petite appli.

Bon courage et cordiales salutations
Robert Dezan
------------------------------------------------------------------------------------------------------------------
Dim Tab_Rep_Path()
Sub Renommer_Fichiers()
Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
ThisWorkbook.Activate
' ----- Sélection du répertoire source
' NOTA : Il est possible d'utiliser une Fonction GetDirectory
' pour sélectionner un répertoire
Chemin = "G:TEST CAR"
' extensions : si Extension1 = "" ==> traitement de tous les
fichiers
Extension1 = "jpg" ' sans le point

' Récupération des chemins complets des sous-répertoires et fichiers
du répertoire nommé
Application.ScreenUpdating = False
' récupération de tous les sous-répertoires et fichiers dans
"Tab_Rep_Path"
Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
LongMax, 0, True)
' action sur chaque fichier
NbF = 0
' Nota : Tab_Rep_Path contient les noms de fichiers complets avec leur
chemins d'accès
' l'extension est vérifiée dans le nom et pas le chemin qui pourrait
aussi contenir des points

Columns("A:B").ClearContents ' POUR TEST sur la feuille active

For n = 1 To UBound(Tab_Rep_Path)
Fic_comp = Tab_Rep_Path(n - 1)
i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
' séparation nom du fichier et chemin de la droite vers la
gauche
For m = i To 1 Step -1
If Mid(Fic_comp, m, 1) = "." Then k = i - m
If Mid(Fic_comp, m, 1) = "" Then Exit For
Next
Ext = Right(Fic_comp, k)
' tester les extensions
If Extension1 = "" Or Ext = Extension1 Then
Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR TEST
copie Ancien nom dans col A
' traitement possible
Ancien = Right(Fic_comp, i - m)
Fic_path = Left(Fic_comp, m)
' traitement du fichier : remplacement caractères et
chiffres
Nouveau = Fct_nom_corrige(Ancien)
' renommer le fichier
If Nouveau <> Ancien Then
NbF = NbF + 1
Name Fic_path & Ancien As Fic_path & Nouveau '
Renomme le fichier.
End If
' POUR TEST : copie Nouveau nom dans la colonne 2 de la
feuille active
Cells(n, 2).Value = Fic_path & Nouveau
End If
Next
Application.ScreenUpdating = True
Application.StatusBar = "Prêt"
MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
End Sub

Function Fct_nom_corrige(ByVal Ancien)
Dim Nouveau As String
Dim nn, mm, zz As Integer
' --- traitement du nom (nombres de tête et caractères accentués)
Nouveau = Ancien
' pour enlever les nombres de tête
For nn = 1 To Len(Ancien)
' --- arrêt de suppression au 1er caractère alpha différent de
" "
If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <= Chr(57)
Or Left(Nouveau, 1) = " " Then
Nouveau = Right(Nouveau, Len(Nouveau) - 1)
End If
Next
' remplace les caractères accentués par leur équivalent sans accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
mm = Len(Nouveau)
For nn = 1 To mm
Caract = Mid(Nouveau, nn, 1)
zz = InStr(1, ListeCar, Caract)
If zz <> 0 Then
Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
Mid(ListeRem, zz, 1))
End If
Next
Fct_nom_corrige = Nouveau
End Function

Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$, MaxChemin,
NbCarMax, _
Idx As Long, Optional SousFldr = True)
'pour empêcher l'examen des ss/répertoires, affecter False à SousFldr
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Fich As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Fich In Dossier.Files
ReDim Preserve Arr(Idx)
Arr(Idx) = Fich.Path
Application.StatusBar = "Examen : " & Fich.Name
If Len(Fich.Path) > NbCarMax Then
MaxChemin = Fich.Path
NbCarMax = Len(Fich.Path)
End If
Idx = Idx + 1
Next

If Not SousFldr Then Exit Sub 'sans les sous dossiers

' traitement récursif des sous dossiers
For Each sousRep In Dossier.SubFolders
'Application.StatusBar = "Rep : " & sousRep.Name
Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax, Idx
Next sousRep

End Sub 'fs
------------------------------------------------------------------------------------

Bonjour,
Je sais pas si cette commande peu t'être utile...
mais elle recupere tous les fichiers JPG du dossier "ajeter" ainsi que de ses sous-dossiers:
en créant le fichier "dirxls.xls"

Sub Dirxls()
Shell "command.com /c dir c:ajeter*.jpg /W/O/S >C:ajeterdirxls.xls", vbHide
End Sub

Sinon tu as aussi cela:

Sub LoadList()
Dim Ndx As Long
With Application.FileSearch
.Filename = "*.jpg"
.LookIn = "C:ajeter"
.SearchSubFolders = True
For Ndx = 1 To .Execute(msoSortByFileName)
'précisez la feuille que vous voulez
Worksheets("Liste des fichiers avec PAth").Cells(Ndx, 1).Value = .FoundFiles(Ndx)
Next Ndx
End With
End Sub
Daniel


"Herdet" <rdezan@noos.fr> a écrit dans le message de news: eaTQMHjBFHA.2788@TK2MSFTNGP15.phx.gbl...
| Bonsoir à tous,
| Je relance un nouveau fil sur le sujet car mon dernier post est déjà perdu
| depuis 3 jours !!!
|
| A l'attention de G'Claire (Jacques ??)
| Je ne sais pas si il est possible de récupérer en une seule commande les
| noms de tous les fichiers d'un répertoire et de ses sous-répertoires car il
| faut appliquer une fonction récursive sur le répertoire principal.
| NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous les
| fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
| efficace.
| Tu trouveras ci-après une amélioration de mon dernier code ( à copier dans
| un module) pour renommer tous les fichiers d'un répertoire et de ses
| sous-répertoires
|
| Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent les
| données et résultats dans les colonnes A et B de la feuille active.
| J'ai laissé tomber l'utilisation du File Object System (FSO) car la fonction
| Name fait le même boulot (Office Pro Excel 2002)
| Pour utiliser un filtre sur plusieurs extensions tu peux :
| - ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
| - remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
| par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2 Or
| Ext = Extension3 Then
|
| En étant un peu ambitieux,on peut aussi améliorer la sélection du répertoire
| à traiter en utilisant la fonction GetDirectory
| Et en ajoutant une boite de dialogue avec la saisie de quelques paramètres
| (texte commun aux photos, préfixes, suffixes, etc...), une sélection
| multiple dans une liste d'extensions et pourquoi pas une petite visionneuse,
| ce bout de code deviendrait une vrai petite appli.
|
| Bon courage et cordiales salutations
| Robert Dezan
| ------------------------------------------------------------------------------------------------------------------
| Dim Tab_Rep_Path()
| Sub Renommer_Fichiers()
| Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
| ThisWorkbook.Activate
| ' ----- Sélection du répertoire source
| ' NOTA : Il est possible d'utiliser une Fonction GetDirectory
| ' pour sélectionner un répertoire
| Chemin = "G:TEST CAR"
| ' extensions : si Extension1 = "" ==> traitement de tous les
| fichiers
| Extension1 = "jpg" ' sans le point
|
| ' Récupération des chemins complets des sous-répertoires et fichiers
| du répertoire nommé
| Application.ScreenUpdating = False
| ' récupération de tous les sous-répertoires et fichiers dans
| "Tab_Rep_Path"
| Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
| LongMax, 0, True)
| ' action sur chaque fichier
| NbF = 0
| ' Nota : Tab_Rep_Path contient les noms de fichiers complets avec leur
| chemins d'accès
| ' l'extension est vérifiée dans le nom et pas le chemin qui pourrait
| aussi contenir des points
|
| Columns("A:B").ClearContents ' POUR TEST sur la feuille active
|
| For n = 1 To UBound(Tab_Rep_Path)
| Fic_comp = Tab_Rep_Path(n - 1)
| i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
| ' séparation nom du fichier et chemin de la droite vers la
| gauche
| For m = i To 1 Step -1
| If Mid(Fic_comp, m, 1) = "." Then k = i - m
| If Mid(Fic_comp, m, 1) = "" Then Exit For
| Next
| Ext = Right(Fic_comp, k)
| ' tester les extensions
| If Extension1 = "" Or Ext = Extension1 Then
| Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR TEST
| copie Ancien nom dans col A
| ' traitement possible
| Ancien = Right(Fic_comp, i - m)
| Fic_path = Left(Fic_comp, m)
| ' traitement du fichier : remplacement caractères et
| chiffres
| Nouveau = Fct_nom_corrige(Ancien)
| ' renommer le fichier
| If Nouveau <> Ancien Then
| NbF = NbF + 1
| Name Fic_path & Ancien As Fic_path & Nouveau '
| Renomme le fichier.
| End If
| ' POUR TEST : copie Nouveau nom dans la colonne 2 de la
| feuille active
| Cells(n, 2).Value = Fic_path & Nouveau
| End If
| Next
| Application.ScreenUpdating = True
| Application.StatusBar = "Prêt"
| MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
| End Sub
|
| Function Fct_nom_corrige(ByVal Ancien)
| Dim Nouveau As String
| Dim nn, mm, zz As Integer
| ' --- traitement du nom (nombres de tête et caractères accentués)
| Nouveau = Ancien
| ' pour enlever les nombres de tête
| For nn = 1 To Len(Ancien)
| ' --- arrêt de suppression au 1er caractère alpha différent de
| " "
| If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <= Chr(57)
| Or Left(Nouveau, 1) = " " Then
| Nouveau = Right(Nouveau, Len(Nouveau) - 1)
| End If
| Next
| ' remplace les caractères accentués par leur équivalent sans accent
| ListeCar = "àáâãäåçèéêëúù"
| ListeRem = "aaaaaaceeeeuu"
| mm = Len(Nouveau)
| For nn = 1 To mm
| Caract = Mid(Nouveau, nn, 1)
| zz = InStr(1, ListeCar, Caract)
| If zz <> 0 Then
| Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
| Mid(ListeRem, zz, 1))
| End If
| Next
| Fct_nom_corrige = Nouveau
| End Function
|
| Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$, MaxChemin,
| NbCarMax, _
| Idx As Long, Optional SousFldr = True)
| 'pour empêcher l'examen des ss/répertoires, affecter False à SousFldr
| Dim fso As Object, Dossier As Object
| Dim sousRep As Object, Fich As Object
|
| Set fso = CreateObject("Scripting.FileSystemObject")
| Set Dossier = fso.GetFolder(LeDossier)
|
| ' examen du dossier courant
| For Each Fich In Dossier.Files
| ReDim Preserve Arr(Idx)
| Arr(Idx) = Fich.Path
| Application.StatusBar = "Examen : " & Fich.Name
| If Len(Fich.Path) > NbCarMax Then
| MaxChemin = Fich.Path
| NbCarMax = Len(Fich.Path)
| End If
| Idx = Idx + 1
| Next
|
| If Not SousFldr Then Exit Sub 'sans les sous dossiers
|
| ' traitement récursif des sous dossiers
| For Each sousRep In Dossier.SubFolders
| 'Application.StatusBar = "Rep : " & sousRep.Name
| Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax, Idx
| Next sousRep
|
| End Sub 'fs
| ------------------------------------------------------------------------------------
|
|
|
|
|

Salut, Herdet et Daniel

En faite, j'en suis a faire des codes tous simple, et quand cela deviens un
peu trop élaboré, j'en fait appel a des plus compétant, et là j'ai fait appel.

Le but de ca que j'ai demandé est de pouvoir renommé dans un dossiers des
photos en .jpeg qui sont classées dans des sous dossiers, et dans ces sous
dossiers avoir encores des sous dossier avec des photos, donc :

Dossier principal = Sous dossier1 + photo
Sous dossier1 = Sous-dossiers2 ou plusieurs sous dossiers + photos

etc

Herdet a du pouvoir trouver la solution,mais je n'arrive pas a la faire
fonctionner, (Peu-être un problème de copier coller), sachant que j'ai
rajouter la déclaration des variables (Car je me demandé si cela ne venait
pas de là).

J'ai essayé de voir ce qui se passé dans le code de HERDET par VBE, mais
cela dépasse mes compétences au niveau VBA, trés débutant moi.

Donc de la a dire si les codes que tu me fournie pourrais m'aider, je ne
serai pas négatif car cela apportera surement quelque-chose, mais comment
l'employer dans cette procédure, je ne sais pas.

En tous les cas la chose la plus positive, c'est de vous intérressé a mon
petit problème.

Merci, G'Claire

Bonjour,
Je sais pas si cette commande peu t'être utile...
mais elle recupere tous les fichiers JPG du dossier "ajeter" ainsi que de ses sous-dossiers:
en créant le fichier "dirxls.xls"

Sub Dirxls()
Shell "command.com /c dir c:ajeter*.jpg /W/O/S >C:ajeterdirxls.xls", vbHide
End Sub

Sinon tu as aussi cela:

Sub LoadList()
Dim Ndx As Long
With Application.FileSearch
.Filename = "*.jpg"
.LookIn = "C:ajeter"
.SearchSubFolders = True
For Ndx = 1 To .Execute(msoSortByFileName)
'précisez la feuille que vous voulez
Worksheets("Liste des fichiers avec PAth").Cells(Ndx, 1).Value = .FoundFiles(Ndx)
Next Ndx
End With
End Sub
Daniel


"Herdet" <rdezan@noos.fr> a écrit dans le message de news: eaTQMHjBFHA.2788@TK2MSFTNGP15.phx.gbl...
| Bonsoir à tous,
| Je relance un nouveau fil sur le sujet car mon dernier post est déjà perdu
| depuis 3 jours !!!
|
| A l'attention de G'Claire (Jacques ??)
| Je ne sais pas si il est possible de récupérer en une seule commande les
| noms de tous les fichiers d'un répertoire et de ses sous-répertoires car il
| faut appliquer une fonction récursive sur le répertoire principal.
| NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous les
| fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
| efficace.
| Tu trouveras ci-après une amélioration de mon dernier code ( à copier dans
| un module) pour renommer tous les fichiers d'un répertoire et de ses
| sous-répertoires
|
| Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent les
| données et résultats dans les colonnes A et B de la feuille active.
| J'ai laissé tomber l'utilisation du File Object System (FSO) car la fonction
| Name fait le même boulot (Office Pro Excel 2002)
| Pour utiliser un filtre sur plusieurs extensions tu peux :
| - ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
| - remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
| par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2 Or
| Ext = Extension3 Then
|
| En étant un peu ambitieux,on peut aussi améliorer la sélection du répertoire
| à traiter en utilisant la fonction GetDirectory
| Et en ajoutant une boite de dialogue avec la saisie de quelques paramètres
| (texte commun aux photos, préfixes, suffixes, etc...), une sélection
| multiple dans une liste d'extensions et pourquoi pas une petite visionneuse,
| ce bout de code deviendrait une vrai petite appli.
|
| Bon courage et cordiales salutations
| Robert Dezan
| ------------------------------------------------------------------------------------------------------------------
| Dim Tab_Rep_Path()
| Sub Renommer_Fichiers()
| Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
| ThisWorkbook.Activate
| ' ----- Sélection du répertoire source
| ' NOTA : Il est possible d'utiliser une Fonction GetDirectory
| ' pour sélectionner un répertoire
| Chemin = "G:TEST CAR"
| ' extensions : si Extension1 = "" ==> traitement de tous les
| fichiers
| Extension1 = "jpg" ' sans le point
|
| ' Récupération des chemins complets des sous-répertoires et fichiers
| du répertoire nommé
| Application.ScreenUpdating = False
| ' récupération de tous les sous-répertoires et fichiers dans
| "Tab_Rep_Path"
| Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
| LongMax, 0, True)
| ' action sur chaque fichier
| NbF = 0
| ' Nota : Tab_Rep_Path contient les noms de fichiers complets avec leur
| chemins d'accès
| ' l'extension est vérifiée dans le nom et pas le chemin qui pourrait
| aussi contenir des points
|
| Columns("A:B").ClearContents ' POUR TEST sur la feuille active
|
| For n = 1 To UBound(Tab_Rep_Path)
| Fic_comp = Tab_Rep_Path(n - 1)
| i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
| ' séparation nom du fichier et chemin de la droite vers la
| gauche
| For m = i To 1 Step -1
| If Mid(Fic_comp, m, 1) = "." Then k = i - m
| If Mid(Fic_comp, m, 1) = "" Then Exit For
| Next
| Ext = Right(Fic_comp, k)
| ' tester les extensions
| If Extension1 = "" Or Ext = Extension1 Then
| Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR TEST
| copie Ancien nom dans col A
| ' traitement possible
| Ancien = Right(Fic_comp, i - m)
| Fic_path = Left(Fic_comp, m)
| ' traitement du fichier : remplacement caractères et
| chiffres
| Nouveau = Fct_nom_corrige(Ancien)
| ' renommer le fichier
| If Nouveau <> Ancien Then
| NbF = NbF + 1
| Name Fic_path & Ancien As Fic_path & Nouveau '
| Renomme le fichier.
| End If
| ' POUR TEST : copie Nouveau nom dans la colonne 2 de la
| feuille active
| Cells(n, 2).Value = Fic_path & Nouveau
| End If
| Next
| Application.ScreenUpdating = True
| Application.StatusBar = "Prêt"
| MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
| End Sub
|
| Function Fct_nom_corrige(ByVal Ancien)
| Dim Nouveau As String
| Dim nn, mm, zz As Integer
| ' --- traitement du nom (nombres de tête et caractères accentués)
| Nouveau = Ancien
| ' pour enlever les nombres de tête
| For nn = 1 To Len(Ancien)
| ' --- arrêt de suppression au 1er caractère alpha différent de
| " "
| If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <= Chr(57)
| Or Left(Nouveau, 1) = " " Then
| Nouveau = Right(Nouveau, Len(Nouveau) - 1)
| End If
| Next
| ' remplace les caractères accentués par leur équivalent sans accent
| ListeCar = "àáâãäåçèéêëúù"
| ListeRem = "aaaaaaceeeeuu"
| mm = Len(Nouveau)
| For nn = 1 To mm
| Caract = Mid(Nouveau, nn, 1)
| zz = InStr(1, ListeCar, Caract)
| If zz <> 0 Then
| Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
| Mid(ListeRem, zz, 1))
| End If
| Next
| Fct_nom_corrige = Nouveau
| End Function
|
| Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$, MaxChemin,
| NbCarMax, _
| Idx As Long, Optional SousFldr = True)
| 'pour empêcher l'examen des ss/répertoires, affecter False à SousFldr
| Dim fso As Object, Dossier As Object
| Dim sousRep As Object, Fich As Object
|
| Set fso = CreateObject("Scripting.FileSystemObject")
| Set Dossier = fso.GetFolder(LeDossier)
|
| ' examen du dossier courant
| For Each Fich In Dossier.Files
| ReDim Preserve Arr(Idx)
| Arr(Idx) = Fich.Path
| Application.StatusBar = "Examen : " & Fich.Name
| If Len(Fich.Path) > NbCarMax Then
| MaxChemin = Fich.Path
| NbCarMax = Len(Fich.Path)
| End If
| Idx = Idx + 1
| Next
|
| If Not SousFldr Then Exit Sub 'sans les sous dossiers
|
| ' traitement récursif des sous dossiers
| For Each sousRep In Dossier.SubFolders
| 'Application.StatusBar = "Rep : " & sousRep.Name
| Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax, Idx
| Next sousRep
|
| End Sub 'fs
| ------------------------------------------------------------------------------------
|
|
|
|
|

Bonjour,
Ce résultat est quand même étonnant à moins que la fonction "Names" n'existe
pas dans Excel 2000 sinon il faudra revenir au FileSystemObject.
N'ayant pas Excel 2000 chez moi, je ferai un essai au bureau demain avec
Excel 2000

En attendant, essayons de faire quelques manip :
1) copier quelques photos .jpg (avec chiffres et caractères accentués) dans
un répertoire de test
2) Dans VBA, corriger Chemin = "G:TEST CAR" avec le path de ton
répertoire de test
3) Dans la Sub Renommer_Fichiers, placer 2 points d'arrêt sur :
==> Fic_comp = Tab_Rep_Path(n - 1)
==> If Nouveau <> Ancien Then
(dans VBA, 1 clic sur bande grise à gauche de la ligne concernée)
4) Lancer la macro "Renommer_Fichiers "
5) Au 1er arrêt de la macro, placer le curseur sur "Fic_comp" : le nom du
1er fichier doit être visible
Si "Fic_comp"est vide, c'est que la fonction "Fct_RecupTousLesFichiers"
n'a pas fonctionné
ou qu'il n'y a pas de .jpg dans le répertoire
6) Continuer l'exécution en cliquant dans le bouton "Exécuter Sub" ou
pas-à-pas avec F8
8) Au 2ème arrêt de la macro, placer le curseur sur "Ancien" puis "Nouveau"
Faire la comparaison.

Lorsqu'il y a un problème, il est important de s'aider de la fonction
"Debug" de suivre le contenu des variables
Menu "Affichage Fenêtre d'Exécution " ou Ctrl G
Voir l'aide en ligne pour Debug pour l'utilisation de Debug.print
Ne pas oublier de mettre les ligne de Debug en commentaire lorsque tout
fonctionne.

Cordiales salutations
Robert


"G'Claire" <jacouille@discution.microsoft.com> a écrit dans le message de
news: AB638734-4F29-4837-B326-F4A9EC5A9FBE@microsoft.com...

Herdet le forum

Je suis désolé, mais je n'arrive pas a faire fonctionner ta macro.

Cela me met directement 0 fichier renomés, même si dans le dossier
d'origine.

Es-ce du au copier /collé que j'ai mal refait ou du fait que je suis sous
excel 2000?

Merci, pour ton aide, G'Claire

Bonsoir à tous,
Je relance un nouveau fil sur le sujet car mon dernier post est déjà
perdu
depuis 3 jours !!!

A l'attention de G'Claire (Jacques ??)
Je ne sais pas si il est possible de récupérer en une seule commande les
noms de tous les fichiers d'un répertoire et de ses sous-répertoires car
il
faut appliquer une fonction récursive sur le répertoire principal.
NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous
les
fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
efficace.
Tu trouveras ci-après une amélioration de mon dernier code ( à copier
dans
un module) pour renommer tous les fichiers d'un répertoire et de ses
sous-répertoires

Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent
les
données et résultats dans les colonnes A et B de la feuille active.
J'ai laissé tomber l'utilisation du File Object System (FSO) car la
fonction
Name fait le même boulot (Office Pro Excel 2002)
Pour utiliser un filtre sur plusieurs extensions tu peux :
- ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
- remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2
Or
Ext = Extension3 Then

En étant un peu ambitieux,on peut aussi améliorer la sélection du
répertoire
à traiter en utilisant la fonction GetDirectory
Et en ajoutant une boite de dialogue avec la saisie de quelques
paramètres
(texte commun aux photos, préfixes, suffixes, etc...), une sélection
multiple dans une liste d'extensions et pourquoi pas une petite
visionneuse,
ce bout de code deviendrait une vrai petite appli.

Bon courage et cordiales salutations
Robert Dezan
------------------------------------------------------------------------------------------------------------------
Dim Tab_Rep_Path()
Sub Renommer_Fichiers()
Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
ThisWorkbook.Activate
' ----- Sélection du répertoire source
' NOTA : Il est possible d'utiliser une Fonction GetDirectory
' pour sélectionner un répertoire
Chemin = "G:TEST CAR"
' extensions : si Extension1 = "" ==> traitement de tous les
fichiers
Extension1 = "jpg" ' sans le point

' Récupération des chemins complets des sous-répertoires et
fichiers
du répertoire nommé
Application.ScreenUpdating = False
' récupération de tous les sous-répertoires et fichiers dans
"Tab_Rep_Path"
Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
LongMax, 0, True)
' action sur chaque fichier
NbF = 0
' Nota : Tab_Rep_Path contient les noms de fichiers complets avec
leur
chemins d'accès
' l'extension est vérifiée dans le nom et pas le chemin qui
pourrait
aussi contenir des points

Columns("A:B").ClearContents ' POUR TEST sur la feuille
active

For n = 1 To UBound(Tab_Rep_Path)
Fic_comp = Tab_Rep_Path(n - 1)
i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
' séparation nom du fichier et chemin de la droite vers la
gauche
For m = i To 1 Step -1
If Mid(Fic_comp, m, 1) = "." Then k = i - m
If Mid(Fic_comp, m, 1) = "" Then Exit For
Next
Ext = Right(Fic_comp, k)
' tester les extensions
If Extension1 = "" Or Ext = Extension1 Then
Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR
TEST
copie Ancien nom dans col A
' traitement possible
Ancien = Right(Fic_comp, i - m)
Fic_path = Left(Fic_comp, m)
' traitement du fichier : remplacement caractères et
chiffres
Nouveau = Fct_nom_corrige(Ancien)
' renommer le fichier
If Nouveau <> Ancien Then
NbF = NbF + 1
Name Fic_path & Ancien As Fic_path & Nouveau '
Renomme le fichier.
End If
' POUR TEST : copie Nouveau nom dans la colonne 2 de la
feuille active
Cells(n, 2).Value = Fic_path & Nouveau
End If
Next
Application.ScreenUpdating = True
Application.StatusBar = "Prêt"
MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
End Sub

Function Fct_nom_corrige(ByVal Ancien)
Dim Nouveau As String
Dim nn, mm, zz As Integer
' --- traitement du nom (nombres de tête et caractères accentués)
Nouveau = Ancien
' pour enlever les nombres de tête
For nn = 1 To Len(Ancien)
' --- arrêt de suppression au 1er caractère alpha différent
de
" "
If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <=
Chr(57)
Or Left(Nouveau, 1) = " " Then
Nouveau = Right(Nouveau, Len(Nouveau) - 1)
End If
Next
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
mm = Len(Nouveau)
For nn = 1 To mm
Caract = Mid(Nouveau, nn, 1)
zz = InStr(1, ListeCar, Caract)
If zz <> 0 Then
Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
Mid(ListeRem, zz, 1))
End If
Next
Fct_nom_corrige = Nouveau
End Function

Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$,
MaxChemin,
NbCarMax, _
Idx As Long, Optional SousFldr = True)
'pour empêcher l'examen des ss/répertoires, affecter False à
SousFldr
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Fich As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Fich In Dossier.Files
ReDim Preserve Arr(Idx)
Arr(Idx) = Fich.Path
Application.StatusBar = "Examen : " & Fich.Name
If Len(Fich.Path) > NbCarMax Then
MaxChemin = Fich.Path
NbCarMax = Len(Fich.Path)
End If
Idx = Idx + 1
Next

If Not SousFldr Then Exit Sub 'sans les sous dossiers

' traitement récursif des sous dossiers
For Each sousRep In Dossier.SubFolders
'Application.StatusBar = "Rep : " & sousRep.Name
Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax,
Idx
Next sousRep

End Sub 'fs
------------------------------------------------------------------------------------

Herdet, le forum

"Fic_comp" est bien vide mais si je continue "Tab_Rep_Path" possède bien un
fichier qui est le premier du dossier (Dossier Path).

Si je continue sur la ligne suivante, "Fic_comp" contient bien une valeur.

Bizard, je fais encore quelques tets et vous tiens au courant.

Merci, G'Claire

Bonjour,
Ce résultat est quand même étonnant à moins que la fonction "Names" n'existe
pas dans Excel 2000 sinon il faudra revenir au FileSystemObject.
N'ayant pas Excel 2000 chez moi, je ferai un essai au bureau demain avec
Excel 2000

En attendant, essayons de faire quelques manip :
1) copier quelques photos .jpg (avec chiffres et caractères accentués) dans
un répertoire de test
2) Dans VBA, corriger Chemin = "G:TEST CAR" avec le path de ton
répertoire de test
3) Dans la Sub Renommer_Fichiers, placer 2 points d'arrêt sur :
==> Fic_comp = Tab_Rep_Path(n - 1)
==> If Nouveau <> Ancien Then
(dans VBA, 1 clic sur bande grise à gauche de la ligne concernée)
4) Lancer la macro "Renommer_Fichiers "
5) Au 1er arrêt de la macro, placer le curseur sur "Fic_comp" : le nom du
1er fichier doit être visible
Si "Fic_comp"est vide, c'est que la fonction "Fct_RecupTousLesFichiers"
n'a pas fonctionné
ou qu'il n'y a pas de .jpg dans le répertoire
6) Continuer l'exécution en cliquant dans le bouton "Exécuter Sub" ou
pas-à-pas avec F8
8) Au 2ème arrêt de la macro, placer le curseur sur "Ancien" puis "Nouveau"
Faire la comparaison.

Lorsqu'il y a un problème, il est important de s'aider de la fonction
"Debug" de suivre le contenu des variables
Menu "Affichage Fenêtre d'Exécution " ou Ctrl G
Voir l'aide en ligne pour Debug pour l'utilisation de Debug.print
Ne pas oublier de mettre les ligne de Debug en commentaire lorsque tout
fonctionne.

Cordiales salutations
Robert


"G'Claire" <jacouille@discution.microsoft.com> a écrit dans le message de
news: AB638734-4F29-4837-B326-F4A9EC5A9FBE@microsoft.com...

Herdet le forum

Je suis désolé, mais je n'arrive pas a faire fonctionner ta macro.

Cela me met directement 0 fichier renomés, même si dans le dossier
d'origine.

Es-ce du au copier /collé que j'ai mal refait ou du fait que je suis sous
excel 2000?

Merci, pour ton aide, G'Claire

Bonsoir à tous,
Je relance un nouveau fil sur le sujet car mon dernier post est déjà
perdu
depuis 3 jours !!!

A l'attention de G'Claire (Jacques ??)
Je ne sais pas si il est possible de récupérer en une seule commande les
noms de tous les fichiers d'un répertoire et de ses sous-répertoires car
il
faut appliquer une fonction récursive sur le répertoire principal.
NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous
les
fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
efficace.
Tu trouveras ci-après une amélioration de mon dernier code ( à copier
dans
un module) pour renommer tous les fichiers d'un répertoire et de ses
sous-répertoires

Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent
les
données et résultats dans les colonnes A et B de la feuille active.
J'ai laissé tomber l'utilisation du File Object System (FSO) car la
fonction
Name fait le même boulot (Office Pro Excel 2002)
Pour utiliser un filtre sur plusieurs extensions tu peux :
- ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
- remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2
Or
Ext = Extension3 Then

En étant un peu ambitieux,on peut aussi améliorer la sélection du
répertoire
à traiter en utilisant la fonction GetDirectory
Et en ajoutant une boite de dialogue avec la saisie de quelques
paramètres
(texte commun aux photos, préfixes, suffixes, etc...), une sélection
multiple dans une liste d'extensions et pourquoi pas une petite
visionneuse,
ce bout de code deviendrait une vrai petite appli.

Bon courage et cordiales salutations
Robert Dezan
------------------------------------------------------------------------------------------------------------------
Dim Tab_Rep_Path()
Sub Renommer_Fichiers()
Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
ThisWorkbook.Activate
' ----- Sélection du répertoire source
' NOTA : Il est possible d'utiliser une Fonction GetDirectory
' pour sélectionner un répertoire
Chemin = "G:TEST CAR"
' extensions : si Extension1 = "" ==> traitement de tous les
fichiers
Extension1 = "jpg" ' sans le point

' Récupération des chemins complets des sous-répertoires et
fichiers
du répertoire nommé
Application.ScreenUpdating = False
' récupération de tous les sous-répertoires et fichiers dans
"Tab_Rep_Path"
Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
LongMax, 0, True)
' action sur chaque fichier
NbF = 0
' Nota : Tab_Rep_Path contient les noms de fichiers complets avec
leur
chemins d'accès
' l'extension est vérifiée dans le nom et pas le chemin qui
pourrait
aussi contenir des points

Columns("A:B").ClearContents ' POUR TEST sur la feuille
active

For n = 1 To UBound(Tab_Rep_Path)
Fic_comp = Tab_Rep_Path(n - 1)
i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
' séparation nom du fichier et chemin de la droite vers la
gauche
For m = i To 1 Step -1
If Mid(Fic_comp, m, 1) = "." Then k = i - m
If Mid(Fic_comp, m, 1) = "" Then Exit For
Next
Ext = Right(Fic_comp, k)
' tester les extensions
If Extension1 = "" Or Ext = Extension1 Then
Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR
TEST
copie Ancien nom dans col A
' traitement possible
Ancien = Right(Fic_comp, i - m)
Fic_path = Left(Fic_comp, m)
' traitement du fichier : remplacement caractères et
chiffres
Nouveau = Fct_nom_corrige(Ancien)
' renommer le fichier
If Nouveau <> Ancien Then
NbF = NbF + 1
Name Fic_path & Ancien As Fic_path & Nouveau '
Renomme le fichier.
End If
' POUR TEST : copie Nouveau nom dans la colonne 2 de la
feuille active
Cells(n, 2).Value = Fic_path & Nouveau
End If
Next
Application.ScreenUpdating = True
Application.StatusBar = "Prêt"
MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
End Sub

Function Fct_nom_corrige(ByVal Ancien)
Dim Nouveau As String
Dim nn, mm, zz As Integer
' --- traitement du nom (nombres de tête et caractères accentués)
Nouveau = Ancien
' pour enlever les nombres de tête
For nn = 1 To Len(Ancien)
' --- arrêt de suppression au 1er caractère alpha différent
de
" "
If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <=
Chr(57)
Or Left(Nouveau, 1) = " " Then
Nouveau = Right(Nouveau, Len(Nouveau) - 1)
End If
Next
' remplace les caractères accentués par leur équivalent sans
accent
ListeCar = "àáâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
mm = Len(Nouveau)
For nn = 1 To mm
Caract = Mid(Nouveau, nn, 1)
zz = InStr(1, ListeCar, Caract)
If zz <> 0 Then
Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
Mid(ListeRem, zz, 1))
End If
Next
Fct_nom_corrige = Nouveau
End Function

Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$,
MaxChemin,
NbCarMax, _
Idx As Long, Optional SousFldr = True)
'pour empêcher l'examen des ss/répertoires, affecter False à
SousFldr
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Fich As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Fich In Dossier.Files
ReDim Preserve Arr(Idx)
Arr(Idx) = Fich.Path
Application.StatusBar = "Examen : " & Fich.Name
If Len(Fich.Path) > NbCarMax Then
MaxChemin = Fich.Path
NbCarMax = Len(Fich.Path)
End If
Idx = Idx + 1
Next

If Not SousFldr Then Exit Sub 'sans les sous dossiers

' traitement récursif des sous dossiers
For Each sousRep In Dossier.SubFolders
'Application.StatusBar = "Rep : " & sousRep.Name
Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax,
Idx
Next sousRep

End Sub 'fs
------------------------------------------------------------------------------------

HERDET, Daniel, le forum

HA, petit filou, j'ai trouvé la cause du problème, c'est l'extention "JPG"
au lieu de (JPEG), ensuite il m'a fallu déclarer les variables, donc je les
aient mise a la suite sans me soucier quelle déclaration il fallait faire.

Le renommage se fait trés bien, mise a part que cela m'oublie toujours un
fichier sur l'ensemble, je ne vois pas pourquoi, et si je relance la
procédure cela le renomme.

Exemple si au total, il y a :
10 fichiers cela en renomme 9
20 Fichiers cela en renomme 19

Et par conséquence en met le nombre moins un dans la feuille pour test.

J'essaye de définir, sur lequel dossier cela arrive, car a priori c'est
toujours dans le derniers des sous dossiers

Voila, merci, G'Claire

Salut, Herdet et Daniel

En faite, j'en suis a faire des codes tous simple, et quand cela deviens un
peu trop élaboré, j'en fait appel a des plus compétant, et là j'ai fait appel.

Le but de ca que j'ai demandé est de pouvoir renommé dans un dossiers des
photos en .jpeg qui sont classées dans des sous dossiers, et dans ces sous
dossiers avoir encores des sous dossier avec des photos, donc :

Dossier principal = Sous dossier1 + photo
Sous dossier1 = Sous-dossiers2 ou plusieurs sous dossiers + photos

etc

Herdet a du pouvoir trouver la solution,mais je n'arrive pas a la faire
fonctionner, (Peu-être un problème de copier coller), sachant que j'ai
rajouter la déclaration des variables (Car je me demandé si cela ne venait
pas de là).

J'ai essayé de voir ce qui se passé dans le code de HERDET par VBE, mais
cela dépasse mes compétences au niveau VBA, trés débutant moi.

Donc de la a dire si les codes que tu me fournie pourrais m'aider, je ne
serai pas négatif car cela apportera surement quelque-chose, mais comment
l'employer dans cette procédure, je ne sais pas.

En tous les cas la chose la plus positive, c'est de vous intérressé a mon
petit problème.

Merci, G'Claire

Bonjour,
Je sais pas si cette commande peu t'être utile...
mais elle recupere tous les fichiers JPG du dossier "ajeter" ainsi que de ses sous-dossiers:
en créant le fichier "dirxls.xls"

Sub Dirxls()
Shell "command.com /c dir c:ajeter*.jpg /W/O/S >C:ajeterdirxls.xls", vbHide
End Sub

Sinon tu as aussi cela:

Sub LoadList()
Dim Ndx As Long
With Application.FileSearch
.Filename = "*.jpg"
.LookIn = "C:ajeter"
.SearchSubFolders = True
For Ndx = 1 To .Execute(msoSortByFileName)
'précisez la feuille que vous voulez
Worksheets("Liste des fichiers avec PAth").Cells(Ndx, 1).Value = .FoundFiles(Ndx)
Next Ndx
End With
End Sub
Daniel


"Herdet" <rdezan@noos.fr> a écrit dans le message de news: eaTQMHjBFHA.2788@TK2MSFTNGP15.phx.gbl...
| Bonsoir à tous,
| Je relance un nouveau fil sur le sujet car mon dernier post est déjà perdu
| depuis 3 jours !!!
|
| A l'attention de G'Claire (Jacques ??)
| Je ne sais pas si il est possible de récupérer en une seule commande les
| noms de tous les fichiers d'un répertoire et de ses sous-répertoires car il
| faut appliquer une fonction récursive sur le répertoire principal.
| NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous les
| fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
| efficace.
| Tu trouveras ci-après une amélioration de mon dernier code ( à copier dans
| un module) pour renommer tous les fichiers d'un répertoire et de ses
| sous-répertoires
|
| Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent les
| données et résultats dans les colonnes A et B de la feuille active.
| J'ai laissé tomber l'utilisation du File Object System (FSO) car la fonction
| Name fait le même boulot (Office Pro Excel 2002)
| Pour utiliser un filtre sur plusieurs extensions tu peux :
| - ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
| - remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
| par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2 Or
| Ext = Extension3 Then
|
| En étant un peu ambitieux,on peut aussi améliorer la sélection du répertoire
| à traiter en utilisant la fonction GetDirectory
| Et en ajoutant une boite de dialogue avec la saisie de quelques paramètres
| (texte commun aux photos, préfixes, suffixes, etc...), une sélection
| multiple dans une liste d'extensions et pourquoi pas une petite visionneuse,
| ce bout de code deviendrait une vrai petite appli.
|
| Bon courage et cordiales salutations
| Robert Dezan
| ------------------------------------------------------------------------------------------------------------------
| Dim Tab_Rep_Path()
| Sub Renommer_Fichiers()
| Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
| ThisWorkbook.Activate
| ' ----- Sélection du répertoire source
| ' NOTA : Il est possible d'utiliser une Fonction GetDirectory
| ' pour sélectionner un répertoire
| Chemin = "G:TEST CAR"
| ' extensions : si Extension1 = "" ==> traitement de tous les
| fichiers
| Extension1 = "jpg" ' sans le point
|
| ' Récupération des chemins complets des sous-répertoires et fichiers
| du répertoire nommé
| Application.ScreenUpdating = False
| ' récupération de tous les sous-répertoires et fichiers dans
| "Tab_Rep_Path"
| Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
| LongMax, 0, True)
| ' action sur chaque fichier
| NbF = 0
| ' Nota : Tab_Rep_Path contient les noms de fichiers complets avec leur
| chemins d'accès
| ' l'extension est vérifiée dans le nom et pas le chemin qui pourrait
| aussi contenir des points
|
| Columns("A:B").ClearContents ' POUR TEST sur la feuille active
|
| For n = 1 To UBound(Tab_Rep_Path)
| Fic_comp = Tab_Rep_Path(n - 1)
| i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
| ' séparation nom du fichier et chemin de la droite vers la
| gauche
| For m = i To 1 Step -1
| If Mid(Fic_comp, m, 1) = "." Then k = i - m
| If Mid(Fic_comp, m, 1) = "" Then Exit For
| Next
| Ext = Right(Fic_comp, k)
| ' tester les extensions
| If Extension1 = "" Or Ext = Extension1 Then
| Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR TEST
| copie Ancien nom dans col A
| ' traitement possible
| Ancien = Right(Fic_comp, i - m)
| Fic_path = Left(Fic_comp, m)
| ' traitement du fichier : remplacement caractères et
| chiffres
| Nouveau = Fct_nom_corrige(Ancien)
| ' renommer le fichier
| If Nouveau <> Ancien Then
| NbF = NbF + 1
| Name Fic_path & Ancien As Fic_path & Nouveau '
| Renomme le fichier.
| End If
| ' POUR TEST : copie Nouveau nom dans la colonne 2 de la
| feuille active
| Cells(n, 2).Value = Fic_path & Nouveau
| End If
| Next
| Application.ScreenUpdating = True
| Application.StatusBar = "Prêt"
| MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
| End Sub
|
| Function Fct_nom_corrige(ByVal Ancien)
| Dim Nouveau As String
| Dim nn, mm, zz As Integer
| ' --- traitement du nom (nombres de tête et caractères accentués)
| Nouveau = Ancien
| ' pour enlever les nombres de tête
| For nn = 1 To Len(Ancien)
| ' --- arrêt de suppression au 1er caractère alpha différent de
| " "
| If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <= Chr(57)
| Or Left(Nouveau, 1) = " " Then
| Nouveau = Right(Nouveau, Len(Nouveau) - 1)
| End If
| Next
| ' remplace les caractères accentués par leur équivalent sans accent
| ListeCar = "àáâãäåçèéêëúù"
| ListeRem = "aaaaaaceeeeuu"
| mm = Len(Nouveau)
| For nn = 1 To mm
| Caract = Mid(Nouveau, nn, 1)
| zz = InStr(1, ListeCar, Caract)
| If zz <> 0 Then
| Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
| Mid(ListeRem, zz, 1))
| End If
| Next
| Fct_nom_corrige = Nouveau
| End Function
|
| Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$, MaxChemin,
| NbCarMax, _
| Idx As Long, Optional SousFldr = True)
| 'pour empêcher l'examen des ss/répertoires, affecter False à SousFldr
| Dim fso As Object, Dossier As Object
| Dim sousRep As Object, Fich As Object
|
| Set fso = CreateObject("Scripting.FileSystemObject")
| Set Dossier = fso.GetFolder(LeDossier)
|
| ' examen du dossier courant
| For Each Fich In Dossier.Files
| ReDim Preserve Arr(Idx)
| Arr(Idx) = Fich.Path
| Application.StatusBar = "Examen : " & Fich.Name
| If Len(Fich.Path) > NbCarMax Then
| MaxChemin = Fich.Path
| NbCarMax = Len(Fich.Path)
| End If
| Idx = Idx + 1
| Next
|
| If Not SousFldr Then Exit Sub 'sans les sous dossiers
|
| ' traitement récursif des sous dossiers
| For Each sousRep In Dossier.SubFolders
| 'Application.StatusBar = "Rep : " & sousRep.Name
| Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax, Idx
| Next sousRep
|
| End Sub 'fs
| ------------------------------------------------------------------------------------
|
|
|
|
|

Re,

Voici les quelques test que j'ai effectué :

Donc :

1) si 1 dossier et 1 photo -> Pas de renommage de la photo

2) Si 1 dossier et plusieurs photos -> Renommage de X-1 photos (Si 3 donc 2
photos renommées)

3) Si 1 dossier et 1 photo + 1 S/dossiers et plusieurs photos -> Toutes les
photos du dossier son renommées et X-1 dans le sous dossier

4)Si 1 dossier et 1 photo + 1 S/dossiers et plusieurs photos + 1
Sous/dossier sans photos -> Idem que cas N3

Voila un petit test, je vais essayer de comprendre le pourqoi du comment.

Et vous remercient de vote aide, G'Claire

Salut, Herdet et Daniel

En faite, j'en suis a faire des codes tous simple, et quand cela deviens un
peu trop élaboré, j'en fait appel a des plus compétant, et là j'ai fait appel.

Le but de ca que j'ai demandé est de pouvoir renommé dans un dossiers des
photos en .jpeg qui sont classées dans des sous dossiers, et dans ces sous
dossiers avoir encores des sous dossier avec des photos, donc :

Dossier principal = Sous dossier1 + photo
Sous dossier1 = Sous-dossiers2 ou plusieurs sous dossiers + photos

etc

Herdet a du pouvoir trouver la solution,mais je n'arrive pas a la faire
fonctionner, (Peu-être un problème de copier coller), sachant que j'ai
rajouter la déclaration des variables (Car je me demandé si cela ne venait
pas de là).

J'ai essayé de voir ce qui se passé dans le code de HERDET par VBE, mais
cela dépasse mes compétences au niveau VBA, trés débutant moi.

Donc de la a dire si les codes que tu me fournie pourrais m'aider, je ne
serai pas négatif car cela apportera surement quelque-chose, mais comment
l'employer dans cette procédure, je ne sais pas.

En tous les cas la chose la plus positive, c'est de vous intérressé a mon
petit problème.

Merci, G'Claire

Bonjour,
Je sais pas si cette commande peu t'être utile...
mais elle recupere tous les fichiers JPG du dossier "ajeter" ainsi que de ses sous-dossiers:
en créant le fichier "dirxls.xls"

Sub Dirxls()
Shell "command.com /c dir c:ajeter*.jpg /W/O/S >C:ajeterdirxls.xls", vbHide
End Sub

Sinon tu as aussi cela:

Sub LoadList()
Dim Ndx As Long
With Application.FileSearch
.Filename = "*.jpg"
.LookIn = "C:ajeter"
.SearchSubFolders = True
For Ndx = 1 To .Execute(msoSortByFileName)
'précisez la feuille que vous voulez
Worksheets("Liste des fichiers avec PAth").Cells(Ndx, 1).Value = .FoundFiles(Ndx)
Next Ndx
End With
End Sub
Daniel


"Herdet" <rdezan@noos.fr> a écrit dans le message de news: eaTQMHjBFHA.2788@TK2MSFTNGP15.phx.gbl...
| Bonsoir à tous,
| Je relance un nouveau fil sur le sujet car mon dernier post est déjà perdu
| depuis 3 jours !!!
|
| A l'attention de G'Claire (Jacques ??)
| Je ne sais pas si il est possible de récupérer en une seule commande les
| noms de tous les fichiers d'un répertoire et de ses sous-répertoires car il
| faut appliquer une fonction récursive sur le répertoire principal.
| NOTA : Au passage si quelqu'un connait un moyen simple de récupérer tous les
| fichiers obtenu par la fonction "Rechercher" de Windows, cela serait plus
| efficace.
| Tu trouveras ci-après une amélioration de mon dernier code ( à copier dans
| un module) pour renommer tous les fichiers d'un répertoire et de ses
| sous-répertoires
|
| Attention : pour le test , j'ai placé 2 lignes POUR TEST qui écrivent les
| données et résultats dans les colonnes A et B de la feuille active.
| J'ai laissé tomber l'utilisation du File Object System (FSO) car la fonction
| Name fait le même boulot (Office Pro Excel 2002)
| Pour utiliser un filtre sur plusieurs extensions tu peux :
| - ajouter : Extension2 = "xxx" , Extension3 = "yyy", etc...
| - remplacer la ligne If Extension1 = "" Or Ext = Extension1 Then
| par If Extension1 = "" Or Ext = Extension1 Or Ext = Extension2 Or
| Ext = Extension3 Then
|
| En étant un peu ambitieux,on peut aussi améliorer la sélection du répertoire
| à traiter en utilisant la fonction GetDirectory
| Et en ajoutant une boite de dialogue avec la saisie de quelques paramètres
| (texte commun aux photos, préfixes, suffixes, etc...), une sélection
| multiple dans une liste d'extensions et pourquoi pas une petite visionneuse,
| ce bout de code deviendrait une vrai petite appli.
|
| Bon courage et cordiales salutations
| Robert Dezan
| ------------------------------------------------------------------------------------------------------------------
| Dim Tab_Rep_Path()
| Sub Renommer_Fichiers()
| Dim Ancien, Nouveau As String, Flags As Long, DoCenter As Boolean
| ThisWorkbook.Activate
| ' ----- Sélection du répertoire source
| ' NOTA : Il est possible d'utiliser une Fonction GetDirectory
| ' pour sélectionner un répertoire
| Chemin = "G:TEST CAR"
| ' extensions : si Extension1 = "" ==> traitement de tous les
| fichiers
| Extension1 = "jpg" ' sans le point
|
| ' Récupération des chemins complets des sous-répertoires et fichiers
| du répertoire nommé
| Application.ScreenUpdating = False
| ' récupération de tous les sous-répertoires et fichiers dans
| "Tab_Rep_Path"
| Call Fct_RecupTousLesFichiers(Tab_Rep_Path, Chemin, LongMax_Chemin,
| LongMax, 0, True)
| ' action sur chaque fichier
| NbF = 0
| ' Nota : Tab_Rep_Path contient les noms de fichiers complets avec leur
| chemins d'accès
| ' l'extension est vérifiée dans le nom et pas le chemin qui pourrait
| aussi contenir des points
|
| Columns("A:B").ClearContents ' POUR TEST sur la feuille active
|
| For n = 1 To UBound(Tab_Rep_Path)
| Fic_comp = Tab_Rep_Path(n - 1)
| i = Len(Tab_Rep_Path(n - 1)) ' longueur du texte
| ' séparation nom du fichier et chemin de la droite vers la
| gauche
| For m = i To 1 Step -1
| If Mid(Fic_comp, m, 1) = "." Then k = i - m
| If Mid(Fic_comp, m, 1) = "" Then Exit For
| Next
| Ext = Right(Fic_comp, k)
| ' tester les extensions
| If Extension1 = "" Or Ext = Extension1 Then
| Cells(n, 1).Value = Tab_Rep_Path(n - 1) ' POUR TEST
| copie Ancien nom dans col A
| ' traitement possible
| Ancien = Right(Fic_comp, i - m)
| Fic_path = Left(Fic_comp, m)
| ' traitement du fichier : remplacement caractères et
| chiffres
| Nouveau = Fct_nom_corrige(Ancien)
| ' renommer le fichier
| If Nouveau <> Ancien Then
| NbF = NbF + 1
| Name Fic_path & Ancien As Fic_path & Nouveau '
| Renomme le fichier.
| End If
| ' POUR TEST : copie Nouveau nom dans la colonne 2 de la
| feuille active
| Cells(n, 2).Value = Fic_path & Nouveau
| End If
| Next
| Application.ScreenUpdating = True
| Application.StatusBar = "Prêt"
| MsgBox "Traitement terminé : " & NbF & " fichiers renommés"
| End Sub
|
| Function Fct_nom_corrige(ByVal Ancien)
| Dim Nouveau As String
| Dim nn, mm, zz As Integer
| ' --- traitement du nom (nombres de tête et caractères accentués)
| Nouveau = Ancien
| ' pour enlever les nombres de tête
| For nn = 1 To Len(Ancien)
| ' --- arrêt de suppression au 1er caractère alpha différent de
| " "
| If Left(Nouveau, 1) >= Chr(48) And Left(Nouveau, 1) <= Chr(57)
| Or Left(Nouveau, 1) = " " Then
| Nouveau = Right(Nouveau, Len(Nouveau) - 1)
| End If
| Next
| ' remplace les caractères accentués par leur équivalent sans accent
| ListeCar = "àáâãäåçèéêëúù"
| ListeRem = "aaaaaaceeeeuu"
| mm = Len(Nouveau)
| For nn = 1 To mm
| Caract = Mid(Nouveau, nn, 1)
| zz = InStr(1, ListeCar, Caract)
| If zz <> 0 Then
| Nouveau = Replace(Nouveau, Mid(Nouveau, nn, 1),
| Mid(ListeRem, zz, 1))
| End If
| Next
| Fct_nom_corrige = Nouveau
| End Function
|
| Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal LeDossier$, MaxChemin,
| NbCarMax, _
| Idx As Long, Optional SousFldr = True)
| 'pour empêcher l'examen des ss/répertoires, affecter False à SousFldr
| Dim fso As Object, Dossier As Object
| Dim sousRep As Object, Fich As Object
|
| Set fso = CreateObject("Scripting.FileSystemObject")
| Set Dossier = fso.GetFolder(LeDossier)
|
| ' examen du dossier courant
| For Each Fich In Dossier.Files
| ReDim Preserve Arr(Idx)
| Arr(Idx) = Fich.Path
| Application.StatusBar = "Examen : " & Fich.Name
| If Len(Fich.Path) > NbCarMax Then
| MaxChemin = Fich.Path
| NbCarMax = Len(Fich.Path)
| End If
| Idx = Idx + 1
| Next
|
| If Not SousFldr Then Exit Sub 'sans les sous dossiers
|
| ' traitement récursif des sous dossiers
| For Each sousRep In Dossier.SubFolders
| 'Application.StatusBar = "Rep : " & sousRep.Name
| Fct_RecupTousLesFichiers Arr, sousRep.Path, MaxChemin, NbCarMax, Idx
| Next sousRep
|
| End Sub 'fs
| ------------------------------------------------------------------------------------
|
|
|
|
|

Bonjour,
Le test sur Excel 2000 fonctionne bien.
<<Si je continue sur la ligne suivante, "Fic_comp"
contient bien une valeur>>
Cela doit provenir d'un oubli de ma part.
Il faut remplacer la ligne :
For n = 1 To UBound(Tab_Rep_Path)
par
For n = 1 To UBound(Tab_Rep_Path) + 1
pour tenir compte du 1er indice du tableau (0 par défaut)

Autre test :
Mettre un point d'arrêt sur Arr(Idx) = Fich.Path
de la Sub Fct_RecupTousLesFichiers et vérifier les valeurs
prises par Fich.Path car si ces valeurs sont vides c'est
que le répertoire est vide ou mal défini.
Simplification possible :
Supprimer ces 5 lignes qui me servaient dans un autre
programme pour vérifier la longueur maxi des path complets:
Application.StatusBar = "Examen : " & Fich.Name
If Len(Fich.Path) > NbCarMax Then
MaxChemin = Fich.Path
NbCarMax = Len(Fich.Path)
End If
Cordiales salutations
Robert

-----Message d'origine-----
Herdet, le forum

"Fic_comp" est bien vide mais si je
continue "Tab_Rep_Path" possède bien un

fichier qui est le premier du dossier (Dossier Path).

Si je continue sur la ligne suivante, "Fic_comp" contient
bien une valeur.

Bizard, je fais encore quelques tets et vous tiens au
courant.

Merci, G'Claire

Bonjour,
Ce résultat est quand même étonnant à moins que la
fonction "Names" n'existe

pas dans Excel 2000 sinon il faudra revenir au
FileSystemObject.

N'ayant pas Excel 2000 chez moi, je ferai un essai au
bureau demain avec

Excel 2000

En attendant, essayons de faire quelques manip :
1) copier quelques photos .jpg (avec chiffres et
caractères accentués) dans

un répertoire de test
2) Dans VBA, corriger Chemin = "G:TEST CAR" avec le
path de ton

répertoire de test
3) Dans la Sub Renommer_Fichiers, placer 2 points
d'arrêt sur :

==> Fic_comp = Tab_Rep_Path(n - 1)
==> If Nouveau <> Ancien Then
(dans VBA, 1 clic sur bande grise à gauche
de la ligne concernée)

4) Lancer la macro "Renommer_Fichiers "
5) Au 1er arrêt de la macro, placer le curseur
sur "Fic_comp" : le nom du

1er fichier doit être visible
Si "Fic_comp"est vide, c'est que la
fonction "Fct_RecupTousLesFichiers"

n'a pas fonctionné
ou qu'il n'y a pas de .jpg dans le répertoire
6) Continuer l'exécution en cliquant dans le
bouton "Exécuter Sub" ou

pas-Ã -pas avec F8
8) Au 2ème arrêt de la macro, placer le curseur
sur "Ancien" puis "Nouveau"

Faire la comparaison.

Lorsqu'il y a un problème, il est important de s'aider
de la fonction

"Debug" de suivre le contenu des variables
Menu "Affichage Fenêtre d'Exécution " ou Ctrl G
Voir l'aide en ligne pour Debug pour l'utilisation de
Debug.print

Ne pas oublier de mettre les ligne de Debug en
commentaire lorsque tout

fonctionne.

Cordiales salutations
Robert


"G'Claire" <jacouille@discution.microsoft.com> a écrit
dans le message de

news: AB638734-4F29-4837-B326-
F4A9EC5A9FBE@microsoft.com...

Herdet le forum

Je suis désolé, mais je n'arrive pas a faire
fonctionner ta macro.

Cela me met directement 0 fichier renomés, même si
dans le dossier

d'origine.

Es-ce du au copier /collé que j'ai mal refait ou du
fait que je suis sous

excel 2000?

Merci, pour ton aide, G'Claire

Bonsoir à tous,
Je relance un nouveau fil sur le sujet car mon
dernier post est déjÃ

perdu
depuis 3 jours !!!

A l'attention de G'Claire (Jacques ??)
Je ne sais pas si il est possible de récupérer en
une seule commande les

noms de tous les fichiers d'un répertoire et de ses
sous-répertoires car

il
faut appliquer une fonction récursive sur le
répertoire principal.

NOTA : Au passage si quelqu'un connait un moyen
simple de récupérer tous

les
fichiers obtenu par la fonction "Rechercher" de
Windows, cela serait plus

efficace.
Tu trouveras ci-après une amélioration de mon
dernier code ( Ã copier

dans
un module) pour renommer tous les fichiers d'un
répertoire et de ses

sous-répertoires

Attention : pour le test , j'ai placé 2 lignes
POUR TEST qui écrivent

les
données et résultats dans les colonnes A et B de
la feuille active.

J'ai laissé tomber l'utilisation du File Object
System (FSO) car la

fonction
Name fait le même boulot (Office Pro Excel 2002)
Pour utiliser un filtre sur plusieurs extensions tu
peux :

- ajouter : Extension2 = "xxx" , Extension3
= "yyy", etc...

- remplacer la ligne If Extension1 = "" Or Ext =
Extension1 Then

par If Extension1 = "" Or Ext = Extension1
Or Ext = Extension2

Or
Ext = Extension3 Then

En étant un peu ambitieux,on peut aussi améliorer
la sélection du

répertoire
à traiter en utilisant la fonction GetDirectory
Et en ajoutant une boite de dialogue avec la saisie
de quelques

paramètres
(texte commun aux photos, préfixes, suffixes,
etc...), une sélection

multiple dans une liste d'extensions et pourquoi pas
une petite

visionneuse,
ce bout de code deviendrait une vrai petite appli.

Bon courage et cordiales salutations
Robert Dezan
-----------------------------------------------------
-----------------------------------------------------------

--

Dim Tab_Rep_Path()
Sub Renommer_Fichiers()
Dim Ancien, Nouveau As String, Flags As Long,
DoCenter As Boolean

ThisWorkbook.Activate
' ----- Sélection du répertoire source
' NOTA : Il est possible d'utiliser une
Fonction GetDirectory

' pour sélectionner un
répertoire

Chemin = "G:TEST CAR"
' extensions : si Extension1 = "" ==>
traitement de tous les

fichiers
Extension1 = "jpg" ' sans le point

' Récupération des chemins complets des sous-
répertoires et

fichiers
du répertoire nommé
Application.ScreenUpdating = False
' récupération de tous les sous-répertoires
et fichiers dans

"Tab_Rep_Path"
Call Fct_RecupTousLesFichiers(Tab_Rep_Path,
Chemin, LongMax_Chemin,

LongMax, 0, True)
' action sur chaque fichier
NbF = 0
' Nota : Tab_Rep_Path contient les noms de
fichiers complets avec

leur
chemins d'accès
' l'extension est vérifiée dans le nom et
pas le chemin qui

pourrait
aussi contenir des points

Columns("A:B").ClearContents ' POUR TEST
sur la feuille

active

For n = 1 To UBound(Tab_Rep_Path)
Fic_comp = Tab_Rep_Path(n - 1)
i = Len(Tab_Rep_Path(n - 1)) ' longueur
du texte

' séparation nom du fichier et chemin
de la droite vers la

gauche
For m = i To 1 Step -1
If Mid(Fic_comp, m, 1) = "." Then
k = i - m

If Mid(Fic_comp, m, 1) = "" Then
Exit For

Next
Ext = Right(Fic_comp, k)
' tester les extensions
If Extension1 = "" Or Ext = Extension1
Then

Cells(n, 1).Value = Tab_Rep_Path
(n - 1) ' POUR

TEST
copie Ancien nom dans col A
' traitement possible
Ancien = Right(Fic_comp, i - m)
Fic_path = Left(Fic_comp, m)
' traitement du fichier :
remplacement caractères et

chiffres
Nouveau = Fct_nom_corrige(Ancien)
' renommer le fichier
If Nouveau <> Ancien Then
NbF = NbF + 1
Name Fic_path & Ancien As
Fic_path & Nouveau '

Renomme le fichier.
End If
' POUR TEST : copie Nouveau nom
dans la colonne 2 de la

feuille active
Cells(n, 2).Value = Fic_path &
Nouveau

End If
Next
Application.ScreenUpdating = True
Application.StatusBar = "Prêt"
MsgBox "Traitement terminé : " & NbF & "
fichiers renommés"

End Sub

Function Fct_nom_corrige(ByVal Ancien)
Dim Nouveau As String
Dim nn, mm, zz As Integer
' --- traitement du nom (nombres de tête et
caractères accentués)

Nouveau = Ancien
' pour enlever les nombres de tête
For nn = 1 To Len(Ancien)
' --- arrêt de suppression au 1er
caractère alpha différent

de
" "
If Left(Nouveau, 1) >= Chr(48) And Left
(Nouveau, 1) <=

Chr(57)
Or Left(Nouveau, 1) = " " Then
Nouveau = Right(Nouveau, Len
(Nouveau) - 1)

End If
Next
' remplace les caractères accentués par
leur équivalent sans

accent
ListeCar = "à áâãäåçèéêëúù"
ListeRem = "aaaaaaceeeeuu"
mm = Len(Nouveau)
For nn = 1 To mm
Caract = Mid(Nouveau, nn, 1)
zz = InStr(1, ListeCar, Caract)
If zz <> 0 Then
Nouveau = Replace(Nouveau, Mid
(Nouveau, nn, 1),

Mid(ListeRem, zz, 1))
End If
Next
Fct_nom_corrige = Nouveau
End Function

Sub Fct_RecupTousLesFichiers(Arr() As Variant, ByVal
LeDossier$,

MaxChemin,
NbCarMax, _
Idx As Long, Optional SousFldr =
True)

'pour empêcher l'examen des ss/répertoires,
affecter False Ã

SousFldr
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Fich As Object

Set fso = CreateObject
("Scripting.FileSystemObject")

Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Fich In Dossier.Files
ReDim Preserve Arr(Idx)
Arr(Idx) = Fich.Path
Application.StatusBar = "Examen : " & Fich.Name
If Len(Fich.Path) > NbCarMax Then
MaxChemin = Fich.Path
NbCarMax = Len(Fich.Path)
End If
Idx = Idx + 1
Next

If Not SousFldr Then Exit Sub 'sans les sous
dossiers

' traitement récursif des sous dossiers
For Each sousRep In Dossier.SubFolders
'Application.StatusBar = "Rep : " &
sousRep.Name

Fct_RecupTousLesFichiers Arr, sousRep.Path,
MaxChemin, NbCarMax,

Idx
Next sousRep

End Sub 'fs
-----------------------------------------------------
-------------------------------

.