按小三加粗文本重命名Word文档

Sub 按小三加粗文本重命名Word文档()    
    ' 初始化集合（存储文件完整路径）
    Set fileList = New Collection
    ' 创建FSO对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 定义Windows禁止的文件名非法字符
    illegalChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", vbTab, vbCr, vbLf, "　")
    
    ' ===== 1. 选择目标文件夹 =====
    Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With FileDialog
        .Title = "请选择包含Word文档的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1)
    End With
    
    ' ===== 2. 用FSO收集所有Word文档（先存集合，避免遍历冲突） =====
    Set folder = fso.GetFolder(folderPath)
    For Each file In folder.Files
        ' 过滤.doc和.docx格式（排除其他文件）
        If LCase(fso.GetExtensionName(file.Path)) = "doc" Or LCase(fso.GetExtensionName(file.Path)) = "docx" Then
            fileList.Add file.Path  ' 存储文件完整路径到集合
        End If
    Next file
    
    ' ===== 3. 遍历集合中的文件处理 =====
    For Each filePath In fileList
        ' 获取文件名（从完整路径中提取）
        FileName = fso.GetFileName(filePath)
        
        ' ===== 4. 安全打开文档 =====
        On Error Resume Next
        Set doc = Documents.Open( _
            FileName:=filePath, _
            ReadOnly:=True, _
            Visible:=False, _
            AddToRecentFiles:=False)
        On Error GoTo 0
        
        If Not doc Is Nothing Then
            ' ===== 5. 查找“小三+加粗”文本 =====
            Set findRange = doc.Content.Duplicate
            With findRange.Find
                .ClearFormatting
                .Font.Bold = True
                .Font.Size = 15
                .Format = True
                .Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Execute
            End With
            
            ' ===== 6. 处理找到的文本 =====
            newName = ""
            If findRange.Find.Found Then
                newName = findRange.Text
                newName = Replace(Replace(newName, " ", ""), "　", "")
                For i = 0 To UBound(illegalChars)
                    newName = Replace(newName, illegalChars(i), "")
                Next i
                If Len(newName) > 50 Then newName = Left(newName, 50)
                newName = Trim(newName)
            End If
            
            ' ===== 7. 关闭文档 =====
            doc.Close SaveChanges:=wdDoNotSaveChanges
            Set doc = Nothing
            
            ' ===== 8. 执行重命名 =====
            If newName <> "" Then
                ext = "." & fso.GetExtensionName(filePath)  ' 提取扩展名（带点）
                newPath = folderPath & "\" & newName & ext
                
                ' 处理重名
                num = 1
                Do While fso.FileExists(newPath)
                    newPath = folderPath & "\" & newName & "(" & num & ")" & ext
                    num = num + 1
                    If num > 100 Then Exit Do
                Loop
                
                ' 检查路径长度并执行重命名
                If Len(newPath) <= 260 Then
                    On Error Resume Next
                    fso.MoveFile filePath, newPath  ' FSO的MoveFile实现重命名（同文件夹内即重命名）
                    If Err.Number = 0 Then
                        Debug.Print "成功：" & FileName & " → " & newName & ext
                    Else
                        Debug.Print "失败：" & FileName & "（重命名错误：" & Err.Description & "）"
                    End If
                    On Error GoTo 0
                Else
                    Debug.Print "失败：" & FileName & "（新路径过长）"
                End If
            Else
                Debug.Print "跳过：" & FileName & "（未找到匹配文本或文本无效）"
            End If
        Else
            Debug.Print "跳过：" & FileName & "（无法打开文档）"
        End If
    Next filePath
    
    ' 释放对象
    Set fso = Nothing
    Set folder = Nothing
    Set fileList = Nothing
    
    MsgBox "处理完成！"
End Sub