renommer les noms de fichiers sans les accents

Question

J'ai besoin d'un programme qui convertit tout les fichiers et sous-dossiers d'un dossier en renommant les fichiers sans les accents et espaces, et qui met tout en minuscule. 

Comment faire ?

wardall · Answer

Voici une solution simple:

1) Utilise un controle "DirListBox" pour lister le contenue de ton repertoire. (Tu peux aussi utiliser le FileSystemObject mais ca demande plus de doigté).

2) Boucle a travers la liste pour chacun de tes fichier a renommer.

3) Si l'element trouver dans la liste est de type Fichier Alors:

3A) Utiliser la commande Replace pour remplacer les Accents et les Espaces dans le nom du fichier
(Expl: strNewFichier = Replace(strOldFichier," ",""))

3B)Utilise la commande FileCopy pour renommer tes Fichiers

4) Fin si.

nico · Answer

J'ai besoin de renommer les dossiers aussi ...si quelqu'un peu completer

Voici mon code (compilation de truc trouvé et modifié):

Option Explicit
Private m_fso

Private Sub Form_Load()

    Set m_fso = CreateObject("Scripting.FileSystemObject")
    Me.Width = 8295
    Me.Height = 5790
    Top = (Screen.Height - Me.Height) / 2
    Left = (Screen.Width - Me.Width) / 2
    Label1.Height = 255
    Label1.Width = 1455
    Label1.Left = 1200
    Label1.Top = 240
    Label1.Caption = "Répertoire :"
    Text1.Height = 285
    Text1.Width = 2295
    Text1.Left = 3000
    Text1.Top = 240
    Text1.Text = "c:	est"
    Command1.Height = 375
    Command1.Width = 1815
    Command1.Left = 3000
    Command1.Top = 840
    Command1.Caption = "&Renommer"
    List1.Height = 3570
    List1.Width = 7695
    List1.Left = 240
    List1.Top = 1560
    List1.Clear
    Me.Caption = "Epuration"
End Sub

Private Sub Command1_Click()
   Dim l_Collec   As New Collection
   Dim l_Fichier  As Variant
   Dim l_Folder$
   Dim i          As Integer
   
   Dim strnew As String
   Dim strfolderOLD As String
   Dim strfolderNEW As String
   Dim strShell As String
   Dim x As String
   
   List1.Clear
   Command1.Enabled = False
   l_Folder$ = Text1.Text
   
   'nettoye le folder en cours(sans les fichiers )
   strfolderOLD = m_fso.getfolder(l_Folder$)
   strfolderNEW = Nettoyer_String(strfolderOLD)
   'renomme le dossier
   Name strfolderOLD As strfolderNEW
   
   l_Folder$ = strfolderNEW 'actualisation du nom folder si il y a eu changement
   Text1.Text = strfolderNEW
   
   'cherche les sous-dossiers et les renomme
   x = chercheFolders(m_fso.getfolder(l_Folder$))

   If m_fso.FolderExists(l_Folder$) Then
      Set l_Collec = BuildFileCollectionRecursive(m_fso.getfolder(l_Folder$))
      For i = 1 To l_Collec.Count
         On Error Resume Next
         For Each l_Fichier In l_Collec(i)

       ' strnew = Nettoyer_String(l_Fichier.Path) 'épure le fichier et son path
        '  strnew = MajtoMin(strnew)
'x = ReplaceString(l_Fichier.Path, l_Fichier.Name, "")

''x = m_fso.getfolder(l_Folder$)
'x = l_Folder$.subfolders

'Name l_Fichier.Path As strnew
         Next l_Fichier
      Next
      Command1.Enabled = True
   Else
      MsgBox "Répertoire inexistant", vbOKOnly, "C'est trop inzuuuste !"
   End If
End Sub

'pour renommer les dossiers
'Public Function ReplaceString(ByVal sTarget As String, sSearch As String, sNew As String) As String
 '   Dim p As Integer
 '   Do
 '       p = InStr(sTarget, sSearch)
 '       If p Then
 '           sTarget = Left(sTarget, p - 1) + sNew + Mid(sTarget, p + Len(sSearch))
 '       End If
 '   Loop While p
 '   ReplaceString = sTarget
'End Function

Public Function chercheFolders(p_folder)
  Dim l_Folder
  Dim new_l_Folder

    For Each l_Folder In p_folder.subfolders
    new_l_Folder = Nettoyer_String(l_Folder) 'épure le fichier et son path
    new_l_Folder = MajtoMin(new_l_Folder)
    Name l_Folder As new_l_Folder
          Next l_Folder
   
End Function

' BuildFileCollectionRecursive : la récurrence s'applique ici
' Pour chaque sous répertoire, la fonction se rappelle elle-même
' et stocke son contenu dans la collection l_Collec
'
Private Function BuildFileCollectionRecursive(p_folder) As Collection
    Dim l_Folder
    Dim l_Collec        As Collection
    Dim l_collecRecur   As Collection
    
    On Error Resume Next
    Set l_Collec = New Collection
    Set l_collecRecur = New Collection
    l_Collec.Add p_folder.Files
    For Each l_Folder In p_folder.subfolders
        Set l_collecRecur = ConcatenateCollections(l_Collec, BuildFileCollectionRecursive(l_Folder))
    Next l_Folder
    Set BuildFileCollectionRecursive = l_Collec
End Function

' ConcatenateCollections : concatène le contenu de
' la deuxième collection à la première
'
Private Function ConcatenateCollections(p_Collec1 As Collection, p_Collec2 As Collection) As Collection
    Dim l_fic As Variant
    Dim l_Collec As Collection
    
    For Each l_fic In p_Collec2
        p_Collec1.Add l_fic
    Next l_fic
    Set l_Collec = ConcatenateCollections
End Function

Private Sub Form_Resize()
Debug.Print Me.Width, Me.Height
End Sub

'alternative :
'Function TXTVersSQL(message)
 '   message = Replace(message, "'", "''")
 '   TXTVersSQL = message
'End Function

Public Function Nettoyer_String(LeString As String)

'Une fonction très simple qui vas vous permettre
'de "nettoyer" une variable

Let Texte$ = LeString$
Let Longeur% = Len(Texte$)

Do While NumSpc% <= Longeur%

Let NumSpc% = NumSpc% + 1
Let LeChr$ = Mid$(Texte$, NumSpc%, 1)

If LeChr$ = " " Then
LeChr$ = "_"
Else

If LeChr$ = "é" Then
LeChr$ = "e"
Else

If LeChr$ = "è" Then
LeChr$ = "e"
Else

If LCase(LeChr$) = "à" Then
LeChr$ = "a"
Else

If LCase(LeChr$) = "â" Then
LeChr$ = "a"
Else

If LCase(LeChr$) = "(" Then
LeChr$ = "_"
Else

If LCase(LeChr$) = ")" Then
LeChr$ = "_"
Else

If LCase(LeChr$) = "-" Then
LeChr$ = "_"
Else

End If
End If
End If
End If
End If
End If
End If
End If

Let StringFinal$ = StringFinal$ + LeChr$

Loop

Nettoyer_String = StringFinal$
End Function

Public Function MajtoMin(Chaine As String) As String
    Dim i
    Dim a As String * 1 'Chaine de 1 Caractère
    Dim Temp As String
    For i = 1 To Len(Chaine)
        a = Mid(Chaine, i, 1)
        If a = UCase(a) Then
            Temp = Temp & LCase(a)
        Else
            Temp = Temp & LCase(a)
        End If
    Next
    MajtoMin = Temp
End Function

Renommer les noms de fichiers sans les accents

2 réponses

Discussions similaires