我有很多文件在名称“mch”中有一个共同的字符串。在一个文件夹中有数百个以这个公共字符串命名的子文件夹,然后在那些文件中有5个名为相似的图片;例如picfront1234mch。我需要在图片文件的所有名称和它们所在的文件夹的末尾摆脱mch。我尝试了几个不同的例子来自网络但不工作。我写了这段代码来查找子文件夹中的文件名,并删除名称的最后3个字符,但是删除了扩展名。我过去使用过move / copy / rename方法,但是我丢失了一些旧代码,无法弄清楚如何再次使用它。关于如何做得更好的任何建议?
Code ive一直在尝试
Option Explicit
Sub ListFiles()
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
'Assign the top folder to a variable
strTopFolderName = "C:\Users\aholiday\Desktop\Test"
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim str As String
Debug.Print Now
Application.SendKeys "^g ^a {DEL}"
Application.ScreenUpdating = False
'Loop through each folder in the Topfolder
For Each objFile In objFolder.Files
str = objFile.Name
Debug.Print str
'delete last 3 chara of string
str = Left(str, Len(str) - 3)
Debug.Print str
Next objFile
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
Application.ScreenUpdating = True
End Sub
答案 0 :(得分:0)
<强>用法:强>
RemoveTextFromFileName "mch", "I:\stackoverflow\temp"
Sub RemoveTextFromFileName(txt As String, FolderName As String) Dim file If Not Right(FolderName, 1) = "\" Then FolderName = FolderName & "\" file = Dir(FolderName) While (file "") If InStr(file, txt) > 0 Then FileCopy FolderName & file, FolderName & Replace(file, txt, "") Kill FolderName & file End If file = Dir Wend End Sub
更新:从文件夹,子文件夹和文件名中删除字符串。
这些函数将递归搜索根文件夹及其所有子文件夹以重命名文件和文件夹。
<强>用法:强>
Public Sub ProcessFoldersAndFiles()
ReplaceStringFileNames "C:\Data Files\mch files\", "mch"
ReplaceStringDirectories"C:\Data Files\mch files\", "mch"
End Sub
以下是功能:
Sub ReplaceStringDirectories(FolderPath As String, SearchString As String, Optional ReplacementString As String = "", Optional fso As Object)
Dim fld, thisFolder
Dim NewName As String, PathOnly As String
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
Set thisFolder = fso.getFolder(FolderPath)
For Each fld In thisFolder.Subfolders
ReplaceStringDirectories fld.Path, SearchString, ReplacementString
Next
If InStr(thisFolder.Name, SearchString) Then
NewName = Replace(thisFolder.Name, SearchString, ReplacementString, , , vbTextCompare)
PathOnly = Left(thisFolder.Path, InStrRev(thisFolder.Path, "\"))
Do Until Not fso.FolderExists(PathOnly & NewName)
NewName = "_" & NewName
Loop
thisFolder.Name = NewName
End If
End Sub
Sub ReplaceStringFileNames(FolderPath As String, SearchString As String, Optional ReplacementString As String = "", Optional fso As Object)
Dim f, fld, thisFolder
Dim NewName As String, PathOnly As String
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
Set thisFolder = fso.getFolder(FolderPath)
For Each fld In thisFolder.Subfolders
ReplaceStringFileNames fld.Path, SearchString, ReplacementString
Next
For Each f In thisFolder.Files
If InStr(f.Name, SearchString) Then
NewName = Replace(f.Name, SearchString, ReplacementString, , , vbTextCompare)
PathOnly = Left(f.Path, InStrRev(thisFolder.Path, "\"))
Do Until Not fso.FolderExists(PathOnly & NewName)
NewName = "_" & NewName
Loop
f.Name = NewName
End If
Next
End Sub