VBA: 一键批量重命名PDF文件

Option Explicit

Sub RefreshPDF_files()

    Dim folderPath As String
    Dim oldString As String
    Dim newString As String
    Dim fileName As String
    Dim newFileName As String
    Dim filePath As String
    Dim newFilePath As String
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim processCount As Integer
    Dim skipCount As Integer
    Dim failCount As Integer
    Dim wt As Worksheet
    Dim errMsg As String

    On Error GoTo ErrorHandler

    ' 设置工作表
    On Error Resume Next
    Set wt = ThisWorkbook.Worksheets("RenamePDF")
    On Error GoTo 0

    If wt Is Nothing Then
        MsgBox "Worksheet 'RenamePDF' not found!", vbCritical, "Error"
        Exit Sub
    End If

    ' 读取参数
    folderPath = Trim(wt.Range("B2").Value)
    oldString = Trim(wt.Range("B4").Value)
    newString = Trim(wt.Range("B6").Value)

    ' 检查新旧字符串相同
    If oldString = newString Then
        MsgBox "Old and new strings are the same, no change needed.", vbInformation, "Notice"
        GoTo CleanUp
    End If

    ' 检查文件夹路径
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderExists(folderPath) Then
        MsgBox "Folder does not exist, pls check!" & vbCrLf & "Path: " & folderPath, vbExclamation, "Error"
        GoTo CleanUp
    End If

    ' 检查字符串为空
    If oldString = "" Or newString = "" Then
        MsgBox "String is empty, pls check!", vbExclamation, "Error"
        GoTo CleanUp
    End If

    ' 遍历处理PDF文件
    Set folder = fso.GetFolder(folderPath)

    processCount = 0
    skipCount = 0
    failCount = 0

    For Each file In folder.Files

        fileName = file.Name

        filePath = file.Path

        If LCase(fso.GetExtensionName(fileName)) = "pdf" Then

            If InStr(fileName, oldString) > 0 Then

                newFileName = Replace(fileName, oldString, newString)

                newFilePath = fso.BuildPath(folderPath, newFileName)

                If fso.FileExists(newFilePath) Then

                    skipCount = skipCount + 1

                Else

                    ' 重命名（带错误处理）
                    On Error Resume Next
                    fso.MoveFile filePath, newFilePath

                    If Err.Number <> 0 Then

                        failCount = failCount + 1

                        errMsg = errMsg & fileName & ": " & Err.Description & vbCrLf

                        Err.Clear

                    Else

                        processCount = processCount + 1

                    End If

                    On Error GoTo 0

                End If

            End If

        End If

    Next file

    ' 输出结果
    wt.Range("B10").Value = processCount
    wt.Range("B11").Value = skipCount
    wt.Range("B12").Value = failCount
    wt.Range("B13").Value = Now

    ' 完成提示
    MsgBox "Done!" & vbCrLf & _
        "Renamed: " & processCount & " files" & vbCrLf & _
        "Skipped: " & skipCount & " files" & vbCrLf & _
        "Failed: " & failCount & " files" & IIf(errMsg <> "", vbCrLf & vbCrLf & "Failed details:" & vbCrLf & errMsg, ""), _
        vbInformation, "Complete"
    GoTo CleanUp

ErrorHandler:
    MsgBox "An error occurred: " & Err.Number & " - " & Err.Description, vbCritical, "Error"

CleanUp:
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
    Set wt = Nothing

End Sub

InStr(fileName, oldString)

InStr(1, fileName, oldString, vbTextCompare)

Replace(fileName, oldString, newString)

Replace(fileName, oldString, newString, , , vbTextCompare)