循環瀏覽文件夾，使用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腳本運行時」 庫>引用 - > Microsoft腳本運行時

在情況下，你沒有看到[Microsoft腳本運行時]上市，只需瀏覽到C:\windows\system32\scrrun.dll，那也應該這樣做。

其次，改變你的代碼，以利用引用的庫如下：

以下兩行：

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

應該由這一條線上進行更換：

Dim fso As New FileSystemObject 

現在運行你的代碼。如果您仍然遇到錯誤，至少這次，錯誤應該有更多關於其來源的細節，而不像之前模糊對象提供的通用錯誤。

Answer 3

如果你想知道，這是我完成的代碼。感謝蒂姆和艾哈邁德的幫助！

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