web-dev-qa-db-fra.com

Parcourez les dossiers en renommant des fichiers répondant à des critères spécifiques à l'aide de VBA

Je suis nouveau dans VBA (et n’ai que peu de formation en Java), mais j’ai assemblé ce morceau de code à l’aide d’autres publications et j’ai heurté un mur.

J'essaie d'écrire du code qui parcourt chaque fichier d'un dossier en vérifiant si chaque fichier répond à certains critères. Si les critères sont remplis, les noms de fichiers doivent être modifiés, en écrasant (ou en supprimant auparavant) tous les fichiers existants portant le même nom. Les copies de ces fichiers nouvellement renommés doivent ensuite être copiées dans un autre dossier. Je crois que je suis très proche, mais mon code refuse de parcourir tous les fichiers et/ou bloque Excel lorsqu'il est exécuté. Aidez-moi, s'il vous plaît? :-)

Sub RenameImages()

Const FILEPATH As String = _
"C:\\CurrentPath"
Const NEWPATH As String = _
"C:\\AditionalPath"


Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String

Dim FileExistsbol As Boolean

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

strfile = Dir(FILEPATH)

Do While (strfile <> "")
  Debug.Print strfile
  If Mid$(strfile, 4, 1) = "_" Then
    fprefix = Left$(strfile, 3)
    fsuffix = Right$(strfile, 5)
    freplace = "Page"
    propfname = FILEPATH & fprefix & freplace & fsuffix
    FileExistsbol = FileExists(propfname)
      If FileExistsbol Then
      Kill propfname
      End If
    Name FILEPATH & strfile As propfname
    'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
  End If

  strfile = Dir(FILEPATH)

Loop

End Sub

Si cela est utile, les noms de fichier commencent par ABC_mm_dd_hh_Page _ # .jpg et l'objectif est de les réduire à ABCPage # .jpg

Merci SO beaucoup!

excelvbaexcel-vbaexcel-2013
5
Joe K

Je pense que c'est une bonne idée de d'abord collecter tous les noms de fichiers dans un tableau ou une collection avant de commencer à les traiter, en particulier si vous allez les renommer. Si vous ne le faites pas, rien ne garantit que Dir () ne sera pas confondu, ce qui l'amènera à ignorer des fichiers ou à traiter le "même" fichier deux fois. De plus, dans VBA, il n'est pas nécessaire d'échapper des barres obliques inverses dans les chaînes.

Voici un exemple utilisant une collection:

Sub Tester()

    Dim fls, f

    Set fls = GetFiles("D:\Analysis\", "*.xls*")
    For Each f In fls
        Debug.Print f
    Next f

End Sub



Function GetFiles(path As String, Optional pattern As String = "") As Collection
    Dim rv As New Collection, f
    If Right(path, 1) <> "\" Then path = path & "\"
    f = Dir(path & pattern)
    Do While Len(f) > 0
        rv.Add path & f
        f = Dir() 'no parameter
    Loop
    Set GetFiles = rv
End Function
2
Tim Williams

EDIT: Voir la mise à jour ci-dessous pour une solution alternative.

Votre code a un problème majeur. La dernière ligne avant la fin de Loop est

   ...
   strfile = Dir(FILEPATH)  'This will always return the same filename

Loop
...

Voici ce que votre code devrait être:

   ...
   strfile = Dir()  'This means: get the next file in the same folder

Loop
...

La première fois que vous appelez Dir(), vous devez spécifier un chemin pour la liste des fichiers. Ainsi, avant de commencer la boucle, la ligne:

strfile = Dir(FILEPATH)

est bon. La fonction renverra le premier fichier correspondant aux critères de ce dossier. Une fois que vous avez terminé de traiter le fichier et que vous souhaitez passer au fichier suivant, vous devez appeler Dir() sans spécifier de paramètre pour indiquer que vous êtes intéressé par une itération dans le fichier suivant.

=======

Comme solution alternative, vous pouvez utiliser la classe FileSystemObject fournie à VBA au lieu de créer un objet par le système d'exploitation.

Tout d'abord, ajoutez la bibliothèque "Microsoft Scripting Runtime" en allant dans Outils-> Références-> Microsoft Scripting Runtime

enter image description hereenter image description here

Dans le cas où vous n'avez pas vu [Microsoft Scripting Runtime] répertorié, parcourez simplement jusqu'à C:\windows\system32\scrrun.dll et cela devrait faire la même chose.

Deuxièmement, modifiez votre code pour utiliser la bibliothèque référencée comme suit:

Les deux lignes suivantes:

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

devrait être remplacé par cette seule ligne:

Dim fso As New FileSystemObject

Maintenant, lancez votre code. Si vous faites toujours face à une erreur, du moins cette fois-ci, l'erreur devrait contenir plus de détails sur son origine, contrairement au générique fourni par l'objet vague d'avant.

3
Ahmad

Au cas où quelqu'un se demanderait, voici mon code fini. Merci à Tim et Ahmad pour leur aide!

Sub RenameImages()

Const FILEPATH As String = "C:\CurrentFilepath\"
Const NEWPATH As String = "C:\NewFilepath\"


Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String
Dim fls, f

Set fls = GetFiles(FILEPATH)
For Each f In fls
    Debug.Print f
    strfile = Dir(f)
      If Mid$(strfile, 4, 1) = "_" Then
        fprefix = Left$(strfile, 3)
        fsuffix = Right$(strfile, 5)
        freplace = "Page"
        propfname = FILEPATH & fprefix & freplace & fsuffix
        FileExistsbol = FileExists(propfname)
          If FileExistsbol Then
          Kill propfname
          End If
        Name FILEPATH & strfile As propfname
        'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
      End If
Next f
End Sub

Function GetFiles(path As String, Optional pattern As String = "") As Collection
    Dim rv As New Collection, f
    If Right(path, 1) <> "\" Then path = path & "\"
    f = Dir(path & pattern)
    Do While Len(f) > 0
        rv.Add path & f
        f = Dir() 'no parameter
    Loop
    Set GetFiles = rv
End Function

Function FileExists(fullFileName As String) As Boolean
    If fullFileName = "" Then
        FileExists = False
    Else
        FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
    End If
End Function
1
Joe K