Ottenere le intestazioni da un documento di Word

Come posso ottenere un elenco di tutti i titoli di un documento word utilizzando VBA?

Intendi come questa funzione createOutline (che in realtà copia tutte le intestazioni da un documento word sorgente in un nuovo documento word):

(Credo che la funzione astrHeadings = _docSource. GetCrossReferenceItems (wdRefTypeHeading) sia la chiave di questo programma e dovrebbe consentire di recuperare ciò che si sta chiedendo)

 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 

AGGIORNAMENTO di @kol il 6 marzo 2018

Sebbene astrHeadings sia un array ( IsArray restituisce True e TypeName restituisce String() ), viene visualizzato un errore di type mismatch quando provo ad accedere ai suoi elementi in VBScript (v5.8.16384 su Windows 10 Pro 1709 16299.248). Questo deve essere un problema specifico di VBScript, perché posso accedere agli elementi se eseguo lo stesso codice nell’editor VBA di Word. Ho finito per ripetere le linee del sumrio, perché funziona anche da VBScript:

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

Il modo più semplice per ottenere un elenco di intestazioni è di scorrere ciclicamente i paragrafi nel documento, ad esempio:

  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 

A proposito, trovo che sia una buona idea rimuovere il carattere finale dell’intervallo di paragrafo. In caso contrario, se si invia la stringa a una finestra di messaggio o un documento, Word visualizza un carattere di controllo aggiuntivo. Per esempio:

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

Questa macro ha funzionato magnificamente per me (Word 2010). Ho esteso leggermente la funzionalità: ora richiede all’utente di inserire un livello minimo e sopprime i sottotitoli sotto quel livello.

 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 

Il metodo più veloce per estrarre tutte le intestazioni (fino 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 

Seguendo il commento di Wikis sulla risposta VonC, ecco il codice che ha funzionato per me. Rende la funzione più veloce.

 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 

Puoi anche creare un sumrio nel documento e copiarlo. Questo separa il para ref dal titolo, che è utile se è necessario presentarlo in un altro contesto. Se non vuoi il ToC nel tuo documento, cancella quello dopo la copia e incolla. JK.

Perché reinventare la ruota così tante volte?!?

Una “lista di tutte le intestazioni” è solo l’indice standard di Word del documento!

Questo è quello che ho ottenuto registrando una macro aggiungendo l’indice al 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