遍历文件夹，使用 VBA 重命名满足特定条件的文件？

Question

我是 VBA 新手（只接受过一点 java 培训），但在此处的其他帖子的帮助下组装了这段代码并且碰壁了。

我正在尝试编写将循环浏览文件夹中每个文件的代码，测试每个文件是否符合特定标准。如果满足条件，则应编辑文件名，覆盖（或删除之前）任何现有的同名文件。然后应将这些新重命名的文件的副本复制到不同的文件夹中。我相信我已经很接近了，但是我的代码在运行时拒绝循环遍历所有文件和/或使 Excel 崩溃。请帮忙？ :-)

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

如果有帮助，文件名以 ABC_mm_dd_hh_Page_#.jpg 开头，目标是将它们缩减为 ABCPage#.jpg

非常感谢！

Answer 1

我认为在开始处理它们之前先收集数组或集合中的所有文件名是个好主意，特别是如果您要重命名它们。如果您不这样做，则无法保证您不会混淆 Dir()，导致它跳过文件或处理“相同”文件两次。同样在 VBA 中，不需要转义字符串中的反斜杠。

这是一个使用集合的示例：

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 2

编辑：请参阅下面的更新以获取替代解决方案。

您的代码有一个主要问题.. Loop 结束之前的最后一行是

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

Loop
...

你的代码应该是这样的：

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

Loop
...

你第一次调用Dir()，你应该指定一个列出文件的路径，所以在你进入循环之前，行：

strfile = Dir(FILEPATH)

很好。该函数将返回与该文件夹中的条件匹配的第一个文件。一旦你完成了文件的处理，并且你想要移动到下一个文件，你应该调用Dir()而不指定参数来表明你有兴趣迭代到下一个文件。

=======

作为替代解决方案，您可以使用提供给 VBA 的 FileSystemObject 类，而不是由操作系统创建对象。

首先，通过转到工具->参考->Microsoft Scripting Runtime 添加“Microsoft Scripting Runtime”库

如果您没有看到 [Microsoft Scripting Runtime] 列出，只需浏览到 C:\windows\system32\scrrun.dll 即可。

其次，更改代码以使用引用的库，如下所示：

以下两行：

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

应该换成这一行：

Dim fso As New FileSystemObject

现在运行您的代码。如果您仍然面临错误，至少这一次，错误应该有更多关于其来源的详细信息，这与之前的 vague 对象提供的通用错误不同。

Answer 3

如果有人想知道，这是我完成的代码。感谢 Tim 和 Ahmad 的帮助！

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