删除子文件夹名称中的部分字符串，然后删除其中的文件

Question

我有很多文件在名称“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

Answer 1

<强>用法： 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