Получение заголовков из документа Word

Question

Как получить список всех заголовков в текстовом документе с помощью VBA?

Answer 1

Вы имеете в виду, как этот функции (которая на самом деле скопировать все заголовки из исходного документа слова в новый текстовый документ):

(я считаю, что 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 

UPDATE по @kol 6 марта 2018

astrHeadings Хотя это массив (IsArray возвращает True, и TypeName возвращает String()) Я получаю ошибку type mismatch, когда пытаюсь получить доступ к ее элементам в VBScript (v5.8.16384 на Windows 10 Pro 1709 16299.248). Это должна быть специфическая для VBScript проблема, потому что я могу получить доступ к элементам, если я запускаю один и тот же код в редакторе VBA Word. Я в конечном итоге итерация линии ТОС, так как он работает даже с VBScript:

For Each Paragraph In Doc.TablesOfContents(1).Range.Paragraphs 
    WScript.Echo Paragraph.Range.Text 
Next 

Answer 2

Самый простой способ получить список заголовков, будет перебрать пунктов в документе, например:

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) 

Answer 3

Вы также можете создать Оглавление в документе и скопировать его. Это отделяет пункт ref от заголовка, что удобно, если вам нужно представить это в другом контексте. Если вы не хотите ToC в своем документе, просто удалите его после Copy n Paste. JK.

Answer 4

Этот макрос прекрасно работал для меня (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 

Answer 5

Самый быстрый способ для извлечения всех заголовков (до уровня 5).

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 

Answer 6

Следуя за комментарием VonC от Wikis, вот код, который работал на меня. Это делает функцию быстрее.

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 = "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 longDiff 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. 
    longDiff = Len(strOriginal) - Len(strTemp) 
    GetLevel = (longDiff/2) + 1 
End Function 

Answer 7

Зачем изобретать колесо столько раз?!?

«Список всех заголовков» является стандартным индексом Word документа!

Это то, что я получил от записи макроса при добавлении индекса к документу:

Sub Macro1() 
    ActiveDocument.TablesOfContents.Add Range:=Selection.Range, _ 
     RightAlignPageNumbers:=True, _ 
     UseHeadingStyles:=True, _ 
     UpperHeadingLevel:=1, _ 
     LowerHeadingLevel:=5, _ 
     IncludePageNumbers:=True, _ 
     AddedStyles:="", _ 
     UseHyperlinks:=True, _ 
     HidePageNumbersInWeb:=True, _ 
     UseOutlineLevels:=True 
End Sub