Renomer fichiers (comme W7) en VBA

Version imprimable

Bonjour à tous,

Avant de m'attaquer à une macro qui ne me semble pas simple, je parcours les forums pour apprendre le VBA. Pour finir une macro "d'essai" qui lit les dimensions de fichiers image pour les placer en début de nom, je n'arrive pas à terminer la partie qui consiste à renommer un fichier existant comme le fait Window 7 : nom(1).jpg, nom(2) .jpg, nom(3). .jpg...
J'ai une erreur d’exécution 5 qui se produit à la ligne St = Dir.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
 
Sub Teste_Si_Fichier_Existe_Et_Renome()
Dim NouveauNom, Ext, Su, Ajout As String
Dim Repertoire As String
Dim Fso As Object
Dim Pos, Nbre, Pos1, Pos2, LenEntier As Integer
Dim CasParticulier As Boolean
Dim St As String
Dim Fichier As String
 
'Choix du répertoire
Repertoire = ChoixRepertoire & "\"
 
'première entrée fichier
Fichier = Dir(Repertoire, vbNormal Or vbHidden)
 
' recherche l'extension pour les fichiers qui contiennent
' un ou plusieurs points dans leur nom : 1.5.jpg, nom.suit.1.xls
Ext = Extension(Fichier)
 
Set Fso = CreateObject("Scripting.FileSystemObject")
St = Repertoire & Fichier
 
Ajout = "(1)" 'renomme avec (1)° par défaut
CasParticulier = True
 
While Dir(St) <> ""
    While Fichier_Existe(St)
        'Recherche le fichiers se terminant par (n)
        Pos = InStr(Fichier, ").")
        If Pos <> 0 And CasParticulier Then
            Pos2 = InStr(Fichier, "(")
            LenEntier = Pos - Pos2 - 1
            Su = Mid(Fichier, Pos2 + 1, LenEntier)
            If IsNumeric(Su) And Pos2 >= 2 Then
                Nbre = CInt(Su)
                Nbre = Nbre + 1
                Ajout = "(" & Trim(Str(Nbre)) & ")"
                Pos = Len(Fichier) - (Len(Ext) + LenEntier + 2)
                NouveauNom = Left(Fichier, Pos) & Ajout & Ext
            Else
                'le nom du fichier se termine par une parenthèse
                ' non précédée par un nombre entier
                NouveauNom = Left(Fichier, InStr(Fichier, Ext) - 1) & Ajout & Ext
                CasParticulier = False
            End If
        Else
            NouveauNom = Left(Fichier, InStr(Fichier, Ext) - 1) & Ajout & Ext
        End If
        NouveauNom = Trim(NouveauNom)
        Fso.MoveFile Fichier, NouveauNom
    Wend
St = Dir
Wend
 
End Sub

Merci par avance, je sèche.
Question très subsidiaire. Je m’aperçois que la recherche de la parenthèse ouverte ne permet pas d'obtenir 1(a).jpg puis 1(a)(1).jpg

PS Je me suis basé sur la procédure suivante qui fonctionne

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
Sub Liste_Fichiers_jpg()
 Dim Filtre As String, Fichiers As String, Nomm As String
 On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choisir un dossier..........."
        .Show
        If .SelectedItems.Count > 0 Then
           NomDossier = .SelectedItems(1) & "\"
        End If
    End With
    Filtre = "*.jpg"
    Fichiers = Dir(NomDossier & "\" & Filtre, vbNormal Or vbHidden)
 
    While Fichiers <> ""
        Nomm = Left(Fichiers, Len(Fichiers) - 4)
        Fichiers = Dir
    Wend
End Sub

01/05/2013, 11h08
Daniel.C

Bonjour,

Il est possible que l'erreur se produise quand tu cherches à ouvrir un dossier système.

Bonjour,

Le dossier test que j'utilise est un dossier normal. Si cela peut aider je joints les fonctions appelées par la procédure.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 Function ChoixRepertoire() As String Dim Repert As FileDialog Set Repert = Application.FileDialog(msoFileDialogFolderPicker) Repert.Title = "Choisir le dossier de travail" Repert.Show If Repert.SelectedItems.Count > 0 Then ChoixRepertoire = Repert.SelectedItems(1) Else ' Touche annule ou Excape. Fin macro" End End If End Function Function Fichier_Existe(Path As String) As Boolean If Dir(Path) = "" Then Fichier_Existe = False Else Fichier_Existe = True End If End Function Function Extension(Nomfich As String) As String Dim Ch, S, Ext As String Dim i As Integer Ext = "" Extension = "" i = 1 S = StrReverse(Nomfich) Ch = Mid(S, 1, 1) While Ch <> "." Ext = Ext + Ch i = i + 1 Ch = Mid(S, i, 1) Wend Extension = "." & StrReverse(Ext) End Function
J'ai également oublié de dire que je ne peux pas démarrer la macro si la définition des variables St et Fichier se fait sur la même ligne :
Code:

1 2 3 4 5 Dim St, Fichier As String au lieu de Dim St As String Dim Fichier As String
J'ai également oublié de dire que je ne peux pas démarrer la macro si la définition des variables St et Fichier se fait sur la même ligne :
Code:

1 2 3 4 5 6 Dim St, Fichier As String au lieu de Dim St As String Dim Fichier As String
Ca génère une erreur sur St dans la ligne While Fichier_Existe(St)

Cordialement
Cordialement

01/05/2013, 16h25
SfJ5Rpw8

Quel est le message d'erreur ?

Quelle est l'utilité de l'appel de ta fonction Fichier_Existe ..? qui ne fait rien de plus que le

Code:

While Dir(St) <> ""

sur la ligne précédente ?
01/05/2013, 19h35
NVCfrm

bonjour,

erreur 5:
appel de procédure incorrecte.

place un point d'arrêt avec la touche F9 à la ligne : MoveFile
observe les valeurs de tes variables. pas à pas avec F8
01/05/2013, 20h56
94Skarb

Bonjour et merci pour vos réponses

Je n'avais pas trouvé d'erreur en suivant le code en faisant F8. En lisant la remarque de bbil, je pense avoir fait une erreur de débutant.

En effet dans la macro complète, la procédure débute à

Code:

While Fichier_Existe(St)

la recherche de fichier est faite dans une procédure qui affecte un nouveau nom puis l'enregistre, après un test incomplet d'existence éventuelle, d'un autre fichier portant le nouveau nom.

Dans le cas présent

Code:

While Fichier_Existe(St)

vient en doublon de

Code:

While Dir(St) <> ""

Elle génère très probablement le message d'erreur. En pistant avec F8, le deuxième while (remplacé par un if) lit à nouveau la première entrée (la seconde correspond au fichier renommé).

Je vais repartir sur des bases plus saines.

Pour bbil : j'avais lu le règlement du forum. J'espère l'avoir respecté.

Cordialement,

Bonjour,

Après avoir potassé le VBA, j'arrive à cette procédure qui semble fonctionner.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Sub FichierRenome(OldFich As String, NewFich As String)
Dim FichierInit As String
Dim Ajout As String
Dim FSO As Object
Dim i As Byte
Dim St As String
 
Set FSO = CreateObject("Scripting.FileSystemObject")
St = NewFich
FichierInit = NewFich
i = 1
 
While Fichier_Existe(St)
    Ajout = "(" & Trim(Str(i)) & ")"
    NewFich = NomFichSeul(FichierInit) & Ajout & Ext
    i = i + 1
    St = NewFich
Wend
 
NewFich = Trim(NewFich)
FSO.MoveFile OldFich, NewFich
End Sub

Merci à Marc-L pour la fonction "extraire l'extension"

Code:

1
2
3
4
 
Function ExtFich(Fichier As String) As String
    P = InStrRev(Fichier, "."):  If P Then ExtFich = Mid(Fichier, P)
End Function

17/05/2013, 13h18
94Skarb
Bonjour,

La maco fonctionne, excepté lorsque les fichiers sont de type (1).jpg, (2).jpg.... (n).jpg. Dans ce cas (uniquement), la boucle :
Code:

1 2 3 4 5 For Each Fichier In DossierSource.Files NomFich = Fichier.Name 'traitement du fichier Next Fichier
ne s'arrête pas quand le nombre de fichier d'un dossier mais en traite entre 15 % et 30 % de plus. J'ai fais toute une série de tests sur les différentes procédure, l'erreur se produit au même endroit.

Pour que çà fonctionne je détermine le nombre de fichiers dans le répertoire. Quant le nombre est atteint, je fais un Goto fin de procédure pour sortir de la boucle For Each Fichier. Ca marche, mais ce n'est pas satisfaisant. Si quelqu'un a une idée... j'aimerai comprendre.

(La seule modification apportée à la procédure FichierRenome est de remplacer

Code:

While Fichier_Existe(St)

par

Code:

While FSO.FileExists(St)

ce qui ne change rien).