利用VBA批量重置指定格式文件名

Question

电脑E盘某个文件夹下，有几千张.PNG图片，命名不规则，不方便管理及查阅。
   请教一下，可否利用VBA进行按规则重命名。
   比如有10000张，从第1张开始，命名为：A00001、A00002、......A1000
（如果能在打开文件夹时，选择文件格式后再选择文件，最好了。）

请留下联络方式或百度Hi 我，问题解决了，100分悬赏。(Q：85161959)

Answer 1

在任意Word文档中新建一宏，将下列代码粘贴到此宏中，执行此宏即可完成任务

'以下是需要复制的vba代码：

On Error Resume Next:
'本例代码将指定文件夹中的指定类型文件按 A+4位顺序号 重命名
Dim i As Integer
Dim Str1 As String
Dim PathStr As String
Dim FileTypeStr As String
Dim NewName As String
Dim Objfso
Dim Objfolders

PathStr = InputBox("请输入需要处理的文件所在的文件夹路径：" & vbCrLf & "如：d:\下载图片", "文件夹名称")
If PathStr = "" Or Dir(PathStr, vbDirectory) = "" Then
MsgBox "文件夹输入错误，操作被取消！", vbInformation, "提示"
Exit Sub
End If
If Right(PathStr, 1) = "\" Then
PathStr = Left(PathStr, Len(PathStr))
End If

FileTypeStr = InputBox("请输入需要处理的文件类型：" & vbCrLf & "如：jpg 或者 png 等", "文件类型", "jpg")
If Len(FileTypeStr) <> 3 Then
MsgBox "文件类型输入错误，操作被取消！", vbInformation, "提示"
Exit Sub
End If

Set Objfso = CreateObject("Scripting.FileSystemObject")
Set Objfolders = Objfso.GetFolder(PathStr)

FileTypeStr = "." & LCase(FileTypeStr)
For Each objFile In Objfolders.Files
Str1 = objFile.Name
Str1 = LCase(Str1)
'过滤格式进行重命名
If InStr(1, Str1, FileTypeStr) <> 0 Then
i = i + 1
'格式化新文件名
NewName = PathStr + "\" & "A" & Format(i, "0000") & FileTypeStr
'与新文件同名将被忽略
Objfso.MoveFile objFile, NewName
End If
Next

Set Objfolders = Nothing
Set Objfso = Nothing

MsgBox "重命名过程执行完毕！", vbInformation, "提示"
i = Shell("explorer.exe " & PathStr, vbNormalFocus)