Sérial renommeur

Télécharger le projet
Commenter

Description

Voilà un petit programme qui permet de renommer des fichiers en série (ce qui est très long à faire à la main).

Source / Exemple : 


Dim Rep As String 'Sert un peu à tout
Dim CheminDébut As String 'Pour sauvegarder le chemin de départ
Dim Exten As String 'Pour sauvegarder l'extension de départ
Dim i As Long 'Pour les boucles
Dim j As Long 'Pour les "sous-boucles"
Private Type MonteDesscente 'Type pour utiliser la fonction monté - descendre
  Nom1 As String 'Sauvegarde du premier nom
  Nom2 As String 'Sauvegarde du second nom
End Type
Dim MonDes As MonteDesscente

Private Sub Ajou_Click() 'Procédure d'ajout
  If Fichiers.ListIndex = -1 Then 'On regarde si un fichier est sélectionné
    MsgBox "Veuillez sélectionner un fichier.", vbExclamation + vbOKOnly, "Erreur de sélection"
  Else
    If Len(Dossiers.List(Dossiers.ListIndex)) = 3 Then 'Si le répertoire fait 3 caractère
      For i = 0 To ListARenom.ListCount 'Déjà on regarde si le fichier n'éxiste pas dans la liste
        If LCase(ListARenom.List(i)) = LCase(Dossiers.List(Dossiers.ListIndex) & Fichiers.List(Fichiers.ListIndex)) Then
          MsgBox "Fichier déja existant dans la liste", vbInformation + vbOKOnly, "Fichier déjà existant"
          Exit Sub 'Si oui on affiche un message et on quitte le procédure
        End If
      Next i
      'Sinon on ajoute le fichier à la liste
      ListARenom.AddItem Dossiers.List(Dossiers.ListIndex) & Fichiers.List(Fichiers.ListIndex)
    Else 'Si le répertoire fait plus de 3 caractère ...
      '... comme on peut le voir à la fin lorsque l'on ajoute le fichier
      'on met un anti-slash (\) de plus après le nom du répertoire
      For i = 0 To ListARenom.ListCount 'structure idem qu'au dessus
        If LCase(ListARenom.List(i)) = LCase(Dossiers.List(Dossiers.ListIndex) & "\" & Fichiers.List(Fichiers.ListIndex)) Then
          MsgBox "Fichier déja existant dans la liste", vbInformation + vbOKOnly, "Fichier déjà existant"
          Exit Sub
        End If
      Next i
      ListARenom.AddItem Dossiers.List(Dossiers.ListIndex) & "\" & Fichiers.List(Fichiers.ListIndex)
    End If
  End If
End Sub

Private Sub Ajouter_Click()
  Ajou_Click 'Appel de la procédure Ajou_Click
End Sub

Private Sub AjouterTout_Click()
  AjouTout_Click 'Appel de la procédure AjouTout_Click
End Sub

Private Sub AjouTout_Click() 'Procédure d'ajout de tout les fichiers d'un répertoire
  If Len(Dossiers.List(Dossiers.ListIndex)) = 3 Then 'c'est un peu pareil que Ajou_Click
    CheminDébut = Dossiers.List(Dossiers.ListIndex)
  Else
    CheminDébut = Dossiers.List(Dossiers.ListIndex) & "\"
  End If
  For i = 0 To Fichiers.ListCount - 1
    For j = 0 To ListARenom.ListCount - 1
      If LCase(ListARenom.List(j)) = LCase(CheminDébut & Fichiers.List(i)) Then
        MsgBox "Fichier déja existant dans la liste", vbInformation + vbOKOnly, "Fichier déjà existant"
        Exit Sub
      End If
    Next j
    ListARenom.AddItem CheminDébut & Fichiers.List(i)
  Next i
End Sub

Private Sub ChiTexExt_Click() 'Menu Comment renommer 1
  ChiTexExt.Checked = True 'On "Checked" ou pas les menus
  TexChiTexExt.Checked = False
  TexChiExt.Checked = False
  TexPart1.Visible = False 'Et on rend visible ou invisible les textes
  TexPart2.Visible = True
  TexChiffre.Left = 120 'Puis enfin on place les éléments
  TexPart2.Width = 2295
  TexPart2.Left = 840
End Sub

Private Sub Desc_Click() 'Procédure pour descendre un élément de la liste
  If ListARenom.ListIndex <> ListARenom.ListCount - 1 Then 'on regarde si il y a un fichier de sélectionner
    MonDes.Nom1 = ListARenom.List(ListARenom.ListIndex) 'on enregistre le nom1
    MonDes.Nom2 = ListARenom.List(ListARenom.ListIndex + 1) 'on enregistre le nom2
    ListARenom.List(ListARenom.ListIndex) = MonDes.Nom2 'on remplace les noms
    ListARenom.List(ListARenom.ListIndex + 1) = MonDes.Nom1
    ListARenom.Selected(ListARenom.ListIndex + 1) = True 'on sélectionne la bonne ligne
    'Et le tour est joué
  End If
End Sub

Private Sub Descendre_Click()
  Desc_Click 'Appel de la procédure Desc_Click
End Sub

Private Sub Dossiers_Change()
  Fichiers.Path = Dossiers.Path 'Si le répertoire change on change la liste des fichiers
End Sub

Private Sub EffacerListe_Click()
  EffListe_Click 'Appel de la procédure EffListe_Click
End Sub

Private Sub EffListe_Click() 'Procédure pour effacer la liste
  'On demande une confirmation ...
  Rep = MsgBox("Voulez vous effacer la liste des fichiers ?", vbQuestion + vbYesNo, "Effacement de la liste")
  '... et si c'est bon on efface tout
  If Rep = vbYes Then ListARenom.Clear
End Sub

Private Sub Fichiers_DblClick()
  Ajou_Click 'Appel de la procédure Ajou_Click
End Sub

Private Sub Lecteurs_Change()
  Dossiers.Path = Lecteurs.Drive 'Si le lecteur change on change la liste des répertoires
End Sub

Private Sub ListARenom_DblClick()
  Supprimer_Click 'Appel de la procédure Supprimer_Click
End Sub

Private Sub Mont_Click() 'Idem que Desc_Clisk au "-" près
  If ListARenom.ListIndex <> 0 Then
    MonDes.Nom1 = ListARenom.List(ListARenom.ListIndex)
    MonDes.Nom2 = ListARenom.List(ListARenom.ListIndex - 1)
    ListARenom.List(ListARenom.ListIndex) = MonDes.Nom2
    ListARenom.List(ListARenom.ListIndex - 1) = MonDes.Nom1
    ListARenom.Selected(ListARenom.ListIndex - 1) = True
  End If
End Sub

Private Sub Monter_Click()
  Mont_Click 'Appel de la procédure Mont_Click
End Sub

Private Sub Quitter_Click()
  End 'On quitte l'application
End Sub

Private Sub Renom_Click() 'La procédure la plus marrante, et oui j'ai nommé la procédure qui sert à RENOMMER
  If ListARenom.ListCount = 0 Then 'Si y'a rien dans la liste on affiche un message
    MsgBox "Il n'y a aucun élément dans la liste des fichiers à renommer", vbInformation + vbOKOnly, "Aucun fichier à renommer"
  Else
    'Affichage d'un message de confirmation
    Rep = MsgBox("Voulez-vous renommer l'intégralité des fichiers se trouvant dans la liste ?", vbQuestion + vbYesNo, "Confirmation avant de renommer")
      'Si c'est oui on continue
      If Rep = vbYes Then
        Barre.Max = ListARenom.ListCount 'Initialisation de la barre
        Barre.Value = 0
        'On demande le chiffre à partir duquel un commence
        Rep = InputBox("Veuillez entrer le chiffre de départ", "Chiffre de départ", "1")
        'On commence la boucle
        For i = 0 To ListARenom.ListCount - 1
        On Error GoTo Prob 'Routine de gestion des erreurs
        CheminDébut = ListARenom.List(i) 'On entre le chemin de départ dans la variable prévue à cette effet
          For j = 1 To Len(ListARenom.List(i)) 'Boucle pour chercher l'extension du fichier
          'On retire un caractère à chaque fois jusqu'à trouver le caractère "."...
          '...ce qui nous permet ensuite de trouver l'extension
          'Ca a l'air compliqué comme ça mais c'est très simple en fait
            If Right(ListARenom.List(i), 1) <> "." Then
              ListARenom.List(i) = Left(ListARenom.List(i), Len(ListARenom.List(i)) - 1)
            Else
              Exten = Right(CheminDébut, Len(CheminDébut) - Len(ListARenom.List(i)) + 1)
              Exit For
            End If
          Next j
          For j = 1 To Len(ListARenom.List(i))
          'On pareil que l'entension mais là il faut trouver "\" pour connaître
          'le nom du répertoire
            If Right(ListARenom.List(i), 1) <> "\" Then
              ListARenom.List(i) = Left(ListARenom.List(i), Len(ListARenom.List(i)) - 1)
            Else
              Exit For
            End If
          Next j
        'Maintenant on regarde quel type de "renommaisont" on doit faire
        'et on l'applique
        If ChiTexExt.Checked = True Then
          If Len(Str(Val(Rep) + ListARenom.ListCount)) + Len(TexPart2.Text) + Len(Exten) > 237 Then
          'si le nom par lequel on veut renommer est trop long on affiche un message
          'et on ne renomme pas car sinon ça plante
            MsgBox "Le nom que vous avez saisi est trop grand et dépasse 237 caractères, il est donc impssible de renommer le fichier", vbCritical + vbOKOnly, "Erreur de longueur"
          Else
          ' si c'est bon on renomme
            Name CheminDébut As ListARenom.List(i) & (Rep + i) & TexPart2.Text & Exten
          End If
        'la structure ci-dessus est la même pour les 3 type de 'renommaisont"
        ElseIf TexChiTexExt.Checked = True Then
          If Len(TexPart1) + Len(Str(Val(Rep) + ListARenom.ListCount)) + Len(TexPart2.Text) + Len(Exten) > 237 Then
            MsgBox "Le nom que vous avez saisi est trop grand et dépasse 237 caractères, il est donc impssible de renommer le fichier", vbCritical + vbOKOnly, "Erreur de longueur"
          Else
            Name CheminDébut As ListARenom.List(i) & TexPart1.Text & (Rep + i) & TexPart2.Text & Exten
          End If
        Else
          If Len(TexPart1) + Len(Str(Val(Rep) + ListARenom.ListCount)) + Len(Exten) > 237 Then
            MsgBox "Le nom que vous avez saisi est trop grand et dépasse 237 caractères, il est donc impssible de renommer le fichier", vbCritical + vbOKOnly, "Erreur de longueur"
          Else
            Name CheminDébut As ListARenom.List(i) & TexPart1.Text & (Rep + i) & Exten
          End If
        End If
        'on met à jour la barre de progression
        Barre.Value = i + 1
        Next i
        'à la fin on efface la liste ...
        ListARenom.Clear
        '... on rafraichis la liste des fichiers ...
        Fichiers.Refresh
        '... on fait une raz de la barre de progression ...
        Barre.Value = 0
        '... et enfin on affiche un message
        MsgBox "Sérial Renommeur a fini de renommer la liste des fichiers.", vbInformation + vbOKOnly, "Opération réalisée avec succès"
      End If
  End If
Exit Sub 'on quitte la procédure pour ne pas exécuter la suite

Prob:
'en cas de problème on affiche un message
MsgBox "Il y a eu un problème lorsque le programme a essayé de renommer le fichier suivant :" + Chr(13) + CheminDébut + Chr(13) + Chr(13) + "Le fichier est peut être en cours d'utilisation ou a déjà été renommé." + Chr(13) + "Le programme s'est arrêter à se fichier.", vbCritical + vbOKOnly, "Erreur"
'et on remet tout à zéro commme ci-dessus
Fichiers.Refresh
ListARenom.Clear
Barre.Value = 0
End Sub

Private Sub Renommer_Click()
  Renom_Click 'Appel de la procédure Renom_Click
End Sub

Private Sub Supp_Click() 'Procédure pour supprimer une entrée de la liste
  If ListARenom.ListIndex = -1 Then 'on regarde si quelque chose est sélectionné
    'si il n'y a rien de sélectionner on affiche un message
    MsgBox "Il n'y a aucun élément sélectionné.", vbExclamation + vbOKOnly, "Aucun élément sélectionné"
  Else
    'idem si il y a quelque chose de sélectionner (mais pas le même ;-)
    Rep = MsgBox("Voulez vous supprimer l'entrée sélectionnée ?", vbQuestion + vbYesNo, "Supression de l'élément")
    'et on retire l'entrée
    If Rep = vbYes Then ListARenom.RemoveItem ListARenom.ListIndex
  End If
End Sub

Private Sub Supprimer_Click()
  Supp_Click 'Appel de la procédure Supp_Click
End Sub

Private Sub TexChiExt_Click() 'Menu comment renommer 3 (structure identique au menu 1)
  ChiTexExt.Checked = False
  TexChiTexExt.Checked = False
  TexChiExt.Checked = True
  TexPart1.Visible = True
  TexPart2.Visible = False
  TexPart1.Width = 2295
  TexPart1.Left = 120
  TexChiffre.Left = 2520
End Sub

Private Sub TexChiffre_KeyPress(KeyAscii As Integer)
  KeyAscii = 0 'On rend le texte non éditable
End Sub

Private Sub TexChiTexExt_Click() 'Menu comment renommer 2 (structure identique au menu 1)
  ChiTexExt.Checked = False
  TexChiTexExt.Checked = True
  TexChiExt.Checked = False
  TexPart1.Visible = True
  TexPart2.Visible = True
  TexPart1.Width = 1095
  TexPart1.Left = 120
  TexChiffre.Left = 1320
  TexPart2.Width = 1095
  TexPart2.Left = 2040
End Sub

Private Sub TexExtension_KeyPress(KeyAscii As Integer)
  KeyAscii = 0 'On rend le texte non éditable
End Sub

Private Sub TexPart1_KeyPress(KeyAscii As Integer)
  'on désactive les touches dont les caractères ne sont pas conformes à ce qui peut être inclus dans un nom de fichier
  If KeyAscii = 34 Or KeyAscii = 42 Or KeyAscii = 47 Or KeyAscii = 58 Or KeyAscii = 60 Or KeyAscii = 62 Or KeyAscii = 63 Or KeyAscii = 92 Or KeyAscii = 124 Then KeyAscii = 0
End Sub

Private Sub TexPart2_Change()
  'on désactive les touches dont les caractères ne sont pas conformes à ce qui peut être inclus dans un nom de fichier
  If KeyAscii = 34 Or KeyAscii = 42 Or KeyAscii = 47 Or KeyAscii = 58 Or KeyAscii = 60 Or KeyAscii = 62 Or KeyAscii = 63 Or KeyAscii = 92 Or KeyAscii = 124 Then KeyAscii = 0
End Sub
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.

Du même auteur (NicoProg)