Obteniendo los títulos de un documento de Word

Question

¿Cómo obtengo una lista de todos los títulos de un documento de Word usando VBA?

Answer 1

Te refieres a esta función (que en realidad copiar todos los encabezados de un documento de Word de origen en un nuevo documento de Word):

(creo que el astrHeadings = _docSource.GetCrossReferenceItems(wdRefTypeHeading) función es la clave en este programa, y ​​debe permitir que le permite recuperar lo que está pidiendo)

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 

ACTUALIZACIÓN por @kol el 6 de marzo 2018

Aunque astrHeadings es una matriz (IsArray devuelve True y TypeName devuelve String()) Obtengo un error type mismatch cuando intento acceder a sus elementos en VBScript (v5.8.16384 en Windows 10 Pro 1709 16299.248). Esto debe ser un problema específico de VBScript, porque puedo acceder a los elementos si ejecuto el mismo código en el editor de VBA de Word. Terminé la iteración de las líneas de la tabla de contenido, ya que funciona incluso desde VBScript:

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

Answer 2

La forma más fácil para obtener una lista de las partidas, es colocar a través de los párrafos del documento, por ejemplo:

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 

Por cierto, creo que es una buena idea eliminar el carácter final del rango de párrafo. De lo contrario, si envía la cadena a un cuadro de mensaje o un documento, Word muestra un carácter de control adicional. Por ejemplo:

Left(DocPara.Range.Text, len(DocPara.Range.Text)-1) 

Answer 3

También puede crear una tabla de contenido en el documento y copiar eso. Esto separa la para ref del título, que es útil si necesita presentar eso en otro contexto. Si no desea que ToC aparezca en su documento, simplemente elimínelo después de Copiar y pegar. JK.

Answer 4

Esta macro funcionó maravillosamente para mí (Word 2010). He ampliado ligeramente la funcionalidad: ahora solicita al usuario ingresar un nivel mínimo y suprime los subtítulos por debajo de ese nivel.

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

Método más rápido para extraer todos los títulos (a 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 

Answer 6

Siguiendo Wikis Comenta sobre VonC Answer, aquí está el código que me funcionó. Hace la función más rápida.

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

¿Por qué reinventar la rueda tantas veces?!?

¡Una "lista de todos los títulos" es solo el índice de Word estándar del documento!

Esto es lo que tengo mediante la grabación de una macro mientras que la adición de índice para el documento:

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