从Word文档中获取标题
Posted
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了从Word文档中获取标题相关的知识，希望对你有一定的参考价值。
如何使用VBA获取word文档中所有标题的列表？
答案
你的意思是这个createOutline函数（它实际上将源word文档中的所有标题复制到新的word文档中）：
（我相信astrHeadings = _docSource.GetCrossReferenceItems(wdRefTypeHeading)函数是这个程序的关键，应该允许你检索你要求的东西）
Public Sub CreateOutline()
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim astrHeadings As Variant
Dim strText As String
Dim intLevel As Integer
Dim intItem As Integer
Set docSource = ActiveDocument
Set docOutline = Documents.Add
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = _
docSource.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Add the text to the document.
rng.InsertAfter strText & vbNewLine
' Set the style of the selected range and
' then collapse the range for the next entry.
rng.Style = "Heading " & intLevel
rng.Collapse wdCollapseEnd
Next intItem
End Sub
Private Function GetLevel(strItem As String) As Integer
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
由@kol于2018年3月6日更新
虽然astrHeadings是一个数组（IsArray返回True，TypeName返回String()）当我尝试访问VBScript中的元素时，我得到一个type mismatch错误（Windows 10 Pro 1709 16299.248上的v5.8.16384）。这必须是特定于VBScript的问题，因为如果我在Word的VBA编辑器中运行相同的代码，我可以访问这些元素。我最终迭代了TOC的行，因为它甚至可以从VBScript中工作：
For Each Paragraph In Doc.TablesOfContents(1).Range.Paragraphs
WScript.Echo Paragraph.Range.Text
Next
另一答案
获取标题列表的最简单方法是遍历文档中的段落，例如：
Sub ReadPara()
Dim DocPara As Paragraph
For Each DocPara In ActiveDocument.Paragraphs
If Left(DocPara.Range.Style, Len("Heading")) = "Heading" Then
Debug.Print DocPara.Range.Text
End If
Next
End Sub
顺便说一句，我发现删除段落范围的最后一个字符是个好主意。否则，如果您将字符串发送到消息框或文档，Word将显示一个额外的控制字符。例如：
Left(DocPara.Range.Text, len(DocPara.Range.Text)-1)
另一答案
这个宏对我很有效（Word 2010）。我稍微扩展了功能：现在它提示用户输入最低级别，并压缩低于该级别的子标题。
Public Sub CreateOutline()
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim astrHeadings As Variant
Dim strText As String
Dim intLevel As Integer
Dim intItem As Integer
Dim minLevel As Integer
Set docSource = ActiveDocument
Set docOutline = Documents.Add
minLevel = 1 'levels above this value won't be copied.
minLevel = CInt(InputBox("This macro will generate a new document that contains only the headers from the existing document. What is the lowest level heading you want?", "2"))
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = _
docSource.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
If intLevel <= minLevel Then
' Add the text to the document.
rng.InsertAfter strText & vbNewLine
' Set the style of the selected range and
' then collapse the range for the next entry.
rng.Style = "Heading " & intLevel
rng.Collapse wdCollapseEnd
End If
Next intItem
End Sub
Private Function GetLevel(strItem As String) As Integer
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
另一答案
提取所有标题的最快方法（LEVEL5）。
Sub EXTRACT_HDNGS()
Dim WDApp As Word.Application 'WORD APP
Dim WDDoc As Word.Document 'WORD DOC
Set WDApp = Word.Application
Set WDDoc = WDApp.ActiveDocument
For Head_n = 1 To 5
Head = ("Heading " & Head_n)
WDApp.Selection.HomeKey wdStory, wdMove
Do
With WDApp.selection
.MoveStart Unit:=wdLine, Count:=1
.Collapse Direction:=wdCollapseEnd
End with
With WDApp.Selection.Find
.ClearFormatting: .text = "":
.MatchWildcards = False: .Forward = True
.Style = WDDoc.Styles(Head)
If .Execute = False Then GoTo Level_exit
.ClearFormatting
End With
Heading_txt = RemoveSpecialChar(WDApp.Selection.Range.text, 1): Debug.Print Heading_txt
Heading_lvl = WDApp.Selection.Range.ListFormat.ListLevelNumber: Debug.Print Heading_lvl
Heading_lne = WDDoc.Range(0, WDApp.Selection.Range.End).Paragraphs.Count: Debug.Print Heading_lne
Heading_pge = WDApp.Selection.Information(wdActiveEndPageNumber): Debug.Print Heading_pge
If Wdapp.Selection.Style = "Heading 1" Then GoTo Level_exit
Wdapp.Selection.Collapse Direction:=wdCollapseStart
Loop
Level_exit:
Next Head_n
End Sub
另一答案
根据维基对VonC回答的评论，以下是适用于我的代码。它使功能更快。
Public Sub CopyHeadingsInNewDoc()
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim astrHeadings As Variant
Dim strText As String
Dim longLevel As Integer
Dim longItem As Integer
Set docSource = ActiveDocument
Set docOutline = Documents.Add
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = _
docSource.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Add the text to the document.
rng.InsertAfter strText & vbNewLine
' Set the style of the selected range and
' then collapse the range for the next entry.
rng.Style = 以上是关于从Word文档中获取标题的主要内容，如果未能解决你的问题，请参考以下文章