Sub CleanUpDocument()
    ' 删除文档内所有的分节符
    DeleteSectionBreaks
    
    ' 删除文档内所有的文本框
    DeleteTextFrames
    
    ' 删除文档内所有的页眉页脚
    DeleteHeadersAndFooters
   
    ' 设置段落字体格式
    SetParagraphFormat
    
    ' 删除空行
    DelSingleEmptyLine

    ' 设置文档的页面布局中的页面设置，上下左右边距为1厘米
    SetPageMarginsTo1cm
    
    ' 另存文档为 docx格式
    SaveAsDocx
End Sub

Sub DeleteSectionBreaks()
    Dim oRange As Range
    Set oRange = ActiveDocument.Content

    ' 使用Find.Execute方法查找并删除所有分节符
    With oRange.Find
        .ClearFormatting
        .Text = "^b"  ' 分节符的代码
        .Replacement.ClearFormatting
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Sub DeleteTextFrames()
    Dim oShape As Shape
    For Each oShape In ActiveDocument.Shapes
        If oShape.Type = msoTextFrame Then
            oShape.Delete
        End If
    Next oShape
End Sub

Sub DeleteHeadersAndFooters()
    Dim sec As Section
    Dim secRange As Range

    ' 遍历文档中的每个节
    For Each sec In ActiveDocument.Sections
        ' 删除主要页眉和页脚内容
        sec.Headers(wdHeaderFooterPrimary).Range.Delete
        sec.Footers(wdHeaderFooterPrimary).Range.Delete
    Next sec

    ' 打开编辑页眉，手动清除可能留下的横线和空白内容
    For Each sec In ActiveDocument.Sections
'        sec.Range.Select ' 选中节的范围
        If Not sec.Headers(wdHeaderFooterPrimary) Is Nothing Then
            sec.Headers(wdHeaderFooterPrimary).LinkToPrevious = False ' 断开与前一节的链接
        End If
    Next sec

    ' 打开编辑页眉
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

    ' 恢复到正常文档视图
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub




'删除所有图
Sub DeletePics()
    Dim shp As Shape
    
    ' 遍历文档中的每一个形状
    For Each shp In ActiveDocument.Shapes
        ' 检查形状是否为图片
        If shp.Type = msoPicture Then
            ' 删除图片
            shp.Delete
        End If
    Next shp
End Sub


Sub SetPageMarginsTo1cm()
    With ActiveDocument.PageSetup
        .LeftMargin = CentimetersToPoints(1)
        .RightMargin = CentimetersToPoints(1)
        .TopMargin = CentimetersToPoints(1)
        .BottomMargin = CentimetersToPoints(1)
        .Gutter = CentimetersToPoints(0) ' 设置装订线为0磅
        .GutterPos = wdGutterPosLeft ' 设置装订线位置为左侧
    End With
End Sub

Sub SetParagraphFormat()
    Dim para As Paragraph
    ' 遍历文档中的每一个段落
    For Each para In ActiveDocument.Paragraphs
        ' 设置段落格式
        With para
            .Alignment = wdAlignParagraphLeft ' 左对齐
            .OutlineLevel = wdOutlineLevelBodyText ' 大纲级别：正文文本
            .LeftIndent = 0 ' 左侧缩进
            .RightIndent = 0 ' 右侧缩进
            .FirstLineIndent = CentimetersToPoints(0.74) ' 首行锁进：2字符（1字符约为0.74厘米）
            .SpaceBefore = 0 ' 段前间距
            .SpaceAfter = 0 ' 段后间距
            .LineSpacingRule = wdLineSpaceSingle ' 行距：单倍行距
            .Range.Font.Name = "宋体" ' 设置字体为宋体
            .Range.Font.Size = 12 ' 设置字号为小四（小四对应12磅）
        End With
    Next para
End Sub


Sub SaveAsDocx()
    Dim FilePath As String
    Dim FileName As String
    Dim NewFilePath As String

    ' 获取当前文档的路径和文件名
    FilePath = ActiveDocument.Path
    FileName = ActiveDocument.Name
    
    ' 构建新文件的路径
    If InStr(FileName, ".docx") = 0 Then
        NewFilePath = FilePath & "\" & Replace(FileName, ".doc", ".docx")
    Else
        NewFilePath = FilePath & "\" & FileName
    End If
    
    ' 另存为docx格式文档
    ActiveDocument.SaveAs2 FileName:=NewFilePath, FileFormat:=wdFormatXMLDocument
End Sub

'2个空白行合并为1个
Sub Combine2EmptyLines()
    Dim para As Paragraph
    Dim i As Integer
    Dim isPrevEmpty As Boolean

    ' 初始化标记和计数器
    isPrevEmpty = False
    i = 0

    ' 遍历文档中的每一个段落
    For Each para In ActiveDocument.Paragraphs
        ' 判断当前段落是否为空行
        If Len(para.Range.Text) = 1 Then
            ' 如果前一个段落也为空，则为连续的两个空行
            If isPrevEmpty Then
                para.Range.Delete ' 删除当前段落
            End If
            ' 更新标记和计数器
            isPrevEmpty = True
            i = i + 1
        Else
            ' 如果当前段落不为空，则重置标记和计数器
            isPrevEmpty = False
            i = 0
        End If
    Next para
End Sub

'去除空白单行
Sub DelSingleEmptyLine()
    Dim para As Paragraph
    Dim rng As Range
    Dim pattern As String
    Dim regEx As Object

    ' 初始化正则表达式
    pattern = "^\s*$" ' 匹配空白字符的正则表达式，即段落内只包含空格、制表符等空白字符
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = False ' 只匹配第一个符合条件的文本
        .MultiLine = False ' 不跨行匹配
        .IgnoreCase = True ' 不区分大小写
        .pattern = pattern ' 设置匹配模式
    End With

    ' 倒序遍历文档中的每一个段落
    For Each para In ActiveDocument.Paragraphs
        ' 使用范围对象检查段落内是否只包含空白字符
        Set rng = para.Range
        If regEx.test(rng.Text) Then
            rng.Delete ' 删除空行
        End If
    Next para
End Sub

' 手动换行符（↓） ^l  替换为 段落标记 ^p
Sub ReplaceLineBreaksWithParagraphs()
    Dim oRange As Range
    Set oRange = ActiveDocument.Content

    With oRange.Find
        .ClearFormatting
        .Text = "^l"  ' 手动换行符的代码
        .Replacement.ClearFormatting
        .Replacement.Text = "^p"  ' 段落标记的代码
        .Execute Replace:=wdReplaceAll
    End With
End Sub

代码说明：

1. 清理图片：通过循环删除文档中的所有形状（包括图片）。
2. 清理空行：检查每个段落，如果段落内容为空，则删除该段落。
3. 改变格式：设置字体、字体大小和段落间距等格式。
4. 重新排版：可以根据需要调整整个文档的段落格式。

使用方法：

1. 打开 Word 文档。
2. 按 Alt + F11 打开 VBA 编辑器。
3. 在 插入 菜单中选择 模块，然后将上述代码粘贴到模块中。
4. 关闭 VBA 编辑器，返回 Word。
5. 按 Alt + F8，选择 CleanDocument，然后点击 运行。

具体根据需求调整代码中的格式设置。