Renommer fichiers

Télécharger le projet
Commenter

Description

Ce code permet de renommer en cascade des fichiers en fonction du nom du dossier et d'un numéro.
Il renomme également tout les fichiers des sous-dossiers et garde l'extension d'origine.

Source / Exemple : 


'====Code du module:

Option Explicit
Sub Prc_LoadForm()

    F_Menu.Show

End Sub
Function Fct_Addre(ZP_Addr As String) As String
    Dim Z_PosSl As Integer
        'Détection de l'arborésence
    Z_PosSl = InStrRev(ZP_Addr, "\")
    ZP_Addr = Left$(ZP_Addr, Z_PosSl)
    Fct_Addre = ZP_Addr
    
End Function

Sub Prc_FileSearch(ZP_ADR As String)
    Dim i, Z_Count As Integer
    Dim Z_Doss1 As String
    
    With Application.FileSearch
        .NewSearch
        .Filename = "*.*"
        .LookIn = ZP_ADR
        .SearchSubFolders = True

        If .Execute(msoSortByNone) > 0 Then
            For i = 1 To .FoundFiles.Count
                    'Si on change de dossier on remet le conteur à 0
                If Left$(.FoundFiles(i), InStrRev(.FoundFiles(i), "\")) <> Z_Doss1 Then
                    Z_Count = 0
                    Z_Doss1 = Left$(.FoundFiles(i), InStrRev(.FoundFiles(i), "\"))
                End If
                
                Z_Count = Z_Count + 1
                
                Call Prc_RenameFile(Z_Count, .FoundFiles(i))
            Next i

        End If

    End With

End Sub

Sub Prc_RenameFile(Z_Count As Integer, ZP_Addr As String)
    Dim Z_Name, Z_Addr As String
    Dim Z_Ext As String
    Dim Z_NewName As String
    Dim Z_Len, Z_PosSlash As Integer

    On Error Resume Next

    Z_Name = ZP_Addr
    Z_Addr = Fct_Addre(ZP_Addr)

    If Right$(Z_Addr, 1) <> "\" Then
         Z_Addr = Z_Addr & "\"
    End If
        'Detection du dernier \ pour trouver le nom du dossier
    Z_PosSlash = InStrRev(Z_Addr, "\", Len(Z_Addr) - 1) + 1
    Z_Len = Len(Z_Addr)
        'Nouveau nom (Nom du dossier)
    Z_NewName = Mid$(Z_Addr, Z_PosSlash, Z_Len - Z_PosSlash)
        'Détection de l'extension
    Z_Ext = Right(Z_Name, Len(Z_Name) - InStrRev(Z_Name, ".") + 1)
        'Recomposition du nom du fichier et de son arborésence
        'Arborésence & Nom du dossier & _ & Extension
    Name (Z_Name) As (Z_Addr & Z_NewName & "_" & Z_Count & Z_Ext)
    
End Sub

'=======================
'====Code du formulaire:

Option Explicit

Private Sub FB_Close_Click()
    Unload F_Menu
End Sub

Private Sub FB_Dir_Click()
    FC_Name = Fct_Addre(Application.GetOpenFilename)
End Sub

Private Sub FB_Exit_Click()
    Application.Quit
End Sub

Private Sub FB_Run_Click()
    FC_Name.BackColor = vbRed
            'Test pour éviter de renommer un lecteur entier
        If Len(F_Menu.FC_Name) < 4 Then Exit Sub
        Call Prc_FileSearch(F_Menu.FC_Name)
    FC_Name.BackColor = vbGreen
End Sub

Conclusion :


/!\ Veuillez à ne pas renommer "C:\Windows" sinon vous aurez des problèmes...
/!\ Par sécurité une adresse de moins de 4 caractères envoie à la fin du programme sans traitement.

Le code n'est pas optimisé à 100% (je suis au courant)

Utilisation:
Cliquer sur le bouton "Dossier"
Selectionner un des fichiers du dossier à renommer
Valider
Cliquer sur le bouton "Renommer"
Une fois que le champs texte est vert c'est fini

NORMALEMENT tout les fichiers du dossier et des sous dossiers seront renommés avec le nom du dossier dans lequel ils se trouvent et un numéro.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.