Obtention des titres à partir D'un document Word

Comment puis-je obtenir une liste de toutes les rubriques d'un document word en utilisant VBA?

20
demandé sur shruti1810 2008-11-08 18:12:15

7 réponses

vous voulez dire comme cette fonction createOutline (qui copie toutes les rubriques d'un document word source dans un nouveau document word):

(je crois que la fonction astrHeadings = _docSource.GetCrossReferenceItems(wdRefTypeHeading) est la clé de ce programme, et devrait vous permettre de récupérer ce que vous demandez)

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

mise à jour par @kol le 6 mars 2018

bien que astrHeadings soit un tableau ( IsArray retourne True , et TypeName retourne String() ) je reçois une erreur type mismatch quand j'essaie d'accéder à ses éléments dans VBScript (v5.8.16384 sur Windows 10 Pro 1709 16299.248). Cela doit être un problème spécifique à VBScript, parce que je peux accéder aux éléments si j'exécute le même code dans L'éditeur VBA de Word. J'ai fini par itérer les lignes du TOC, parce qu'il fonctionne même à partir de VBScript:

For Each Paragraph In Doc.TablesOfContents(1).Range.Paragraphs
  WScript.Echo Paragraph.Range.Text
Next
17
répondu VonC 2018-03-06 12:35:04

la façon la plus facile d'obtenir une liste de titres, est de passer en boucle à travers les paragraphes du document, par exemple:

 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

Par ailleurs, je trouve que c'est une bonne idée pour supprimer le dernier caractère du paragraphe gamme. Autrement, si vous envoyez la chaîne à une boîte de message ou à un document, Word affiche un caractère de contrôle supplémentaire. Par exemple:

Left(DocPara.Range.Text, len(DocPara.Range.Text)-1)
11
répondu JonnyGold 2008-11-09 20:07:54

cette macro a très bien fonctionné pour moi (Word 2010). J'ai légèrement étendu la fonctionnalité: maintenant il invite l'utilisateur à entrer un niveau minimum, et supprime les sous-titres en dessous de ce niveau.

Public Sub CreateOutline()
' from /q/getting-the-headings-from-a-word-document-66246/"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
2
répondu joshoff 2012-08-07 04:19:04

méthode la plus rapide pour extraire tous les titres (JUSQU'au niveau 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
1
répondu dxc 2014-01-27 14:10:52

suite au Commentaire des Wikis sur la réponse de VonC, voici le code qui a fonctionné pour moi. Il rend la fonction plus rapide.

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
1
répondu Enora 2015-02-06 10:42:05

vous pouvez également créer une Table des matières dans le doc et copier cela. Cela sépare le para ref du titre, ce qui est pratique si vous avez besoin de présenter cela dans un autre contexte. Si vous ne voulez pas le ToC dans votre doc, supprimez-le après la copie n coller. JK.

0
répondu JoeK 2012-02-28 16:47:44

Pourquoi réinventer la roue?!?

Une "liste de tous les titres" est juste le Mot standard index du document!

C'est ce que j'ai obtenu en enregistrant une macro tout en ajoutant index au document:

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
0
répondu jumpjack 2017-01-13 08:23:46