Loop through folder, renaming files that meet specific criteria using VBA?

Question

I am new to VBA (and have only a bit of training in java), but assembled this bit of code with the help of other posts here and have hit a wall.

I am trying to write code that will cycle through each file in a folder, testing if each file meets certain criteria. If criteria are met, the file names should be edited, overwriting (or deleting prior) any existing files with the same name. Copies of these newly renamed files should then be copied to a different folder. I believe I'm very close, but my code refuses to cycle through all files and/or crashes Excel when it is run. Help please? :-)

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

If it's helpful, the file names start as ABC_mm_dd_hh_Page_#.jpg and the goal is to cut them down to ABCPage#.jpg

Thanks SO much!

Answer 1

EDIT: See update below for an alternative solution.

Your code has one major problem.. The last line before the Loop end is

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

Loop
...

Here is what your code should be:

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

Loop
...

The fist time you call Dir(), you should specify a path to list files, so before you entered the loop, the line:

strfile = Dir(FILEPATH)

is good. The function will return the first file that matches the criteria in that folder. Once you have finished processing the file, and you want to move to the next file, you should call Dir() without specifying a parameter to indicate that you are interested in iterating to the next file.

=======

As an alternative solution, you can use the FileSystemObject class provided to VBA instead of creating an object by the operating system.

First, add the "Microsoft Scripting Runtime" library by going to Tools->References->Microsoft Scripting Runtime

In case, you did not see [Microsoft Scripting Runtime] listed, just browse to C:\windows\system32\scrrun.dll and that should do the same.

Second, change your code to utilize the referenced library as follows:

The following two lines:

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

should be replaced by this single line:

Dim fso As New FileSystemObject

Now run your code. If you still face an error, at least this time, the error should have more details about its origin, unlike the generic one provided by the vague object from before.

Answer 2

I think it's a good idea to first collect all of the filenames in an array or collection before starting to process them, particularly if you're going to be renaming them. If you don't there's no guarantee you won't confuse Dir(), leading it to skip files or process the "same" file twice. Also in VBA there's no need to escape backslashes in strings.

Here's an example using a 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

Answer 3

In case anyone is wondering, here is my finished code. Thanks to Tim and Ahmad for their help!

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