vba实践+提取word章节标题文本及其起止页码信息

阿德

我用这些办公软件很多年了。

vba实践+提取word章节标题文本及其起止页码信息

声明：需要先打开文档再执行代码。在执行操作前，请先备份文件。

有一个扫描版的pdf文档，进行文字识别后，得到一个与其对应的word文档（每页内容都与pdf文档一一对应）。对该word文档进行了排版，设置好了各种标题样式和大纲级别。现在要求对pdf文档按章节进行拆分，所以想到从这个对应的word中先提取章节标题文本及其起始页码和结尾页码，再根据这些信息对pdf进行拆分和命名。从word中读取的信息放到一个txt中。

需要拆出的章节的标题文本已经提前输入到一个文本文件（LIST.TXT）中，一个标题文本一行，内容结构如下图所示。

实现代码如下。主要思路：先从LIST.TXT中读取一个标题文本，然后用Find方法从word文档中搜索到该标题，通过Selection.Bookmarks("\headinglevel").Range 属性取得该标题下的章节内容，再通过Range.Information(wdActiveEndPageNumber)属性读取该章节起始页码和结束页码。最后所信息写入到一个txt文本文件中。

Sub 提取章节标题及章节起止页码()
'需要的标题已经提前放到LIST.TXT中。从其中读取标题文本到word文档中寻找
'找到标题之后，读取起始页码，把标题文本、起始页码放到一个txt文件中
Dim TiStr As String
Dim TiPar As Paragraph, EndPar As Paragraph, TiRng As Range
Dim StartP As Integer, EndP As Integer, TiCount As Integer
Open "F:\userdata\Desktop\ LIST.TXT" For Input As #1
Open "F:\userdata\Desktop\ TitlePage.TXT" For Append As #2
Open "F:\userdata\Desktop\ NoTitle.TXT" For Append As #3
TiCount = 0
Line Input #1, TiStr '读取第一个标题
Do While Not EOF(1) '未达到结尾时执行循环，应该在文本文件末尾再加一行无意义行，确保所有行读取完
    Selection.HomeKey wdStory '光标加到文首
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = TiStr
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = False
        '开始执行查找，因为可能存在多个TiStr，所以要循环
        If Not .Execute Then
            Print #3, TiStr & "  没有找到" & vbCrLf
            Selection.HomeKey wdStory '光标加到文首
            Do While .Execute
                Set TiPar = Selection.Paragraphs(1)
                If TiPar.OutlineLevel < 4 Then '如果是大纲级别4以上时，执行动作
                    StartP = TiPar.Range.Information(wdActiveEndPageNumber) '获得起始页码
                    Set TiRng = Selection.Bookmarks("\headinglevel").Range
                    Set EndPar = TiRng.Paragraphs(TiRng.Paragraphs.Count)
                    EndP = EndPar.Range.Information(wdActiveEndPageNumber) '获得结束页码
                    Print #2, Left(TiPar.Range, Len(TiPar.Range) - 1) & vbTab & StartP & vbTab & EndP & vbLf '写入信息。文本文件行的结尾用vbcr会发生混乱，应该用vblf
                    TiCount = TiCount + 1 '找到标题，则计数
                    Exit Do
                End If
        End If
    End With
    Line Input #1, TiStr '读取下一个标题文本