批量改名脚本

Const TITLE = "批量改名脚本"

Sub Main
 Dim fso,fdr
 Dim newname
 Dim key
 Dim ask
 Dim num

 key = InputBox("请输入文件名中要被删除的部分", TITLE)
 If Len(key) = 0 Then Exit Sub
 
 ask = (MsgBox("是否逐文件询问？", vbYesNo Or vbQuestion, TITLE) = vbYes)
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set folder = fso.GetFolder(".\")
 num = 0
 For Each file in folder.Files
  If InStr(1, file.Name, key, vbTextCompare) > 0 Then
   newname = Replace(file.Name, key, "", 1, 1, vbTextCompare)
   If ask Then
    If MsgBox("是否将文件" + vbCrLf + file.Name + vbCrLf + "改名为" + vbCrLf + newname, vbYesNo Or vbQuestion, TITLE) = vbYes Then
     file.Name = newname
     num = num + 1
    End If
   Else
    file.Name = newname
    num = num + 1
   End If
  End If
 Next
 MsgBox "文件名搜索完毕，共更改 " + CStr(num) + " 个文件名。", vbInformation, TITLE
 Set folder = Nothing
 Set fso = Nothing
End Sub

Main