Word 文档拆分

本文代码为通过VBA将Word文档按标题进行分页，并构建一个一个字典用于Word文档标题名和保存文件名的一个映射。

 使用时现在initmapper中添加对应。

本文所述方法利用Word的分页，所以需要在分页视图中运行。

    Sub test()

        initMapper()
        Dim page As page, currDoc As Document
        t = Timer
        'Application.Visible = False
        Application.ScreenUpdating = False
        For Each page In Windows(1).Panes(1).Pages
            currDoc = GetDoc(GetTitle(page))
            page.Rectangles(1).Range.Copy()
            currDoc.Range(currDoc.Content.End - 1).Paste()
        Next
        Application.Visible = True
        Application.ScreenUpdating = True
        MsgBox(Timer - t)
        'SaveAndCloseAll
    End Sub
    Function GetTitle(ByVal page As page) As String
        Dim result As String
        result = "No Title"
        With page.Rectangles(1).Range
            For i = 1 To IIf(.Paragraphs.Count > 4, 4, .Paragraphs.Count)
                If .Paragraphs(i).Range.Font.Name = "黑体" Then
                    result = .Paragraphs(i).Range.Text
                    Exit For
                End If
            Next i
        End With
        result = Replace(result, Chr(32), "")
        result = Replace(result, Chr(13), "")
        result = MapTitle(result)
        GetTitle = result & ".doc"
    End Function
    Function MapTitle(ByVal title As String)
        If titles.Exists(title) Then
            MapTitle = titles(title)
        Else
            MapTitle = title
        End If
    End Function
    '初始化标题映射字典

    Sub initMapper()
        titles.Add("混凝土(原材料、配合比)检验批质量验收记录表(Ⅰ)", "混凝土检验批")
        titles.Add("混凝土(施工)检验批质量验收记录表(Ⅱ)", "混凝土检验批")
        titles.Add("混凝土(强度、桩身处理及承载力试验)检验批质量验收记录表(Ⅲ)", "混凝土检验批")
        titles.Add("钢筋(原材料及加工)检验批质量验收记录表(Ⅰ)", "钢筋检验批")
        titles.Add("钢筋(连接及安装)检验批质量验收记录表(Ⅱ)", "钢筋检验批")
        titles.Add("喷射混凝土(原材料)检验批质量验收记录表(Ⅰ)", "喷射混凝土检验批")
        titles.Add("喷射混凝土支护（施工）检验批质量验收记录表(Ⅱ)", "喷射混凝土检验批")
        titles.Add("喷射混凝土支护（养护及强度）检验批质量验收记录表（Ⅲ）", "喷射混凝土检验批")
    End Sub



    Sub SaveAndCloseAll()
        For Each doc In Documents
            doc.Save()
            doc.Close()
        Next
    End Sub


    '通过对象名字获取一个Document对象

    Function GetDoc(ByVal fileName As String) As Document
        If IsDocOpened(fileName) Then
            GetDoc = Documents(fileName)
        ElseIf Dir("D:\" & fileName) <> "" Then
            GetDoc = Documents.Open("D:\" & fileName, Visible:=True)
        Else
            Documents.Add(Visible:=False).SaveAs("D:\" & fileName)
            SetMargin(Documents(fileName))
            GetDoc = Documents(fileName)
        End If
    End Function
    Function IsDocOpened(ByVal DocName As String) As Boolean
        Dim doc As Document
        Dim result As Boolean
        result = False
        For Each doc In Documents
            If doc.Name = DocName Then
                result = True
                Exit For
            End If
        Next
        IsDocOpened = result
    End Function

    Sub SetMargin(ByVal doc As Document)
        With doc.PageSetup
            .TopMargin = CentimetersToPoints(2.3)
            .BottomMargin = CentimetersToPoints(2.3)
            .LeftMargin = CentimetersToPoints(2.3)
            .RightMargin = CentimetersToPoints(2)
        End With
    End Sub