Get the heading number at my Current selection

Question

I have tried Everything I could find to get just the heading number for the Selection in Microsoft Word.

What I tried.

Selection.HomeKey wdline, wdExtend
Selection.Expand wdline
Selection.HomeKey wdParagraph, wdExtend
ect. Simular stuff.

Example of the heading.

4.2.3     This is a heading

Everything I try just gives me the text in the heading and not the number

I want it to return

4.2.3

I cant convert the Documents Number to Text because it will mess with the spacing.

Answer 1

I have solved my issue by using.

Selection.Paragraphs(1).Range.ListFormat.ListString

This gave me just the number.

Why a heading is a Paragraph??? I just don't know.

Answer 2

I had to deal with parsing of Word documents lately and needed to get headings numbers, found out paragraphs for Word increases after every line break.

I made a script that parses word document & builds an array with: - text of the heading - paragraph number (as word understands it) - heading depth - reconctructed heading number

You can query with parGetStr giving a paragraph number as param, the macro will return the heading number from the paragraph num given (ANSWERING THE FORMER QUESTION).

parErase will erase the table (needed if you made changes to the word headings and want to update the table as the array content is build only once when you use parGetStr).

parDraw is not really needed unless you want to show the table in a new document (for debug purposes for example) and rely on other scripts you would have to get (on my github too).

You can find the latest scripts versions here: https://github.com/SMFSW/vbOffice

The "paragraphs" script will be extended and reworked soon. Here is the actual code for it:

' paragraphs
' Get headings and build a table with text, line numbers, paragraph number & depth
' Version: 0.4
' Author: SMFSW, 2016
' Copyright: MIT
'

' TODO: Being able to handle modifications tracking (no count of deleted titles)
' TODO: Find the end of document another way (script may not work on some messy documents)
' TODO: Find a way to handle next heading find not going forward sometimes (which causes end of script)



' par (x, 0) : line in paragraph scale (full line to dot & carriage return / aka paragraph for Word)
' par (x, 1) : pargraph numbering output as string
' par (x, 2) : depth of heading
' par (x, 3) : text of heading
Private par(500, 3) As Variant
Private parCpt As Integer
Private parInit As Boolean


' erase content of global variables & array
Public Sub parErase()
    For i = 0 To 500
        For j = 0 To 3
            par(i, j) = ""
        Next j
    Next i
    parCpt = 0
    parInit = False
End Sub


' return paragraph number of range r
Public Function parGetNum(r As Range) As Double
    Dim rParagraphs As Range
    Dim CurPos As Double
    'If parInit = False Then Call parBuild  ' par tab not needed in parGetNum

    r.Select
    CurPos = ActiveDocument.Bookmarks("\startOfSel").Start
    Set rParagraphs = ActiveDocument.Range(Start:=0, End:=CurPos)
    parGetNum = rParagraphs.paragraphs.Count    ' USE NAME OF THE FUNCTION AS RETURN VALUE
End Function


' return paragraph number of range r as formated string
Public Function parGetStr(r As Range) As String
    Dim CurPos As Double
    Dim tmp As String: tmp = ""
    If parInit = False Then Call parBuild

    r.Select
    CurPos = parGetNum(r)
    For j = 0 To parCpt
        If par(j, 0) >= CurPos Then
            If j <> 0 Then
                tmp = par(j - 1, 1)
            Else
                tmp = 0 ' If before 1st Header, return 0
            End If

            Exit For    ' Exit when found
        End If
    Next j
    parGetStr = tmp
End Function


' add par table in a new document
Public Sub parDraw()
    Dim txtHeaders As Variant
    txtHeaders = Array("line", _
                       "chapter", _
                       "depth", _
                       "txt")

    savePerfContext ActiveDocument
    If parInit = False Then Call parBuild
    Call tabBuild(4, 0, par, txtHeaders)
    restorePerfContext ActiveDocument
End Sub


Private Sub parBuild()
    Dim maxDepth As Integer
    Dim cpt As Integer

    Dim flag As Boolean: flag = True
    Dim memStr As String

    ' parInit set to True before everything else so next calls to parGetXXX will not call parBuild again
    parInit = True

    ' move to the first heading (to determine text to strip for title depth)
    Selection.GoTo What:=wdGoToHeading, Which:=wdGoToFirst
    Selection.StartOf Unit:=wdParagraph
    Selection.MoveEnd Unit:=wdParagraph

    ' find how is called Title in your Word application
    Dim splt
    splt = split(Selection.Range.Style.NameLocal, " ")
    stripHeader = splt(0)
    Erase splt  ' erase temporary var splt

    ' move back to the start of the document
    Selection.HomeKey Unit:=wdStory

    'loop until the end of the document is reached
    parCpt = 0
    While flag = True
        Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext
        Selection.StartOf Unit:=wdParagraph
        Selection.MoveEnd Unit:=wdParagraph

        'get the line data
        strLine = Selection.Range.Text

        'check if the end of the document has been reached
        If memStr Like strLine Then flag = False
        memStr = strLine

        par(parCpt, 0) = parGetNum(Selection.Range)
        par(parCpt, 1) = "" ' init to empty str for later loop
        par(parCpt, 2) = Val(Replace(Selection.Range.Style.NameLocal, stripHeader, ""))
        par(parCpt, 3) = strLine

        ' Determining max depth of titles for later
        If par(parCpt, 2) > maxDepth Then maxDepth = par(parCpt, 0)

        ' Handling junk lines
        If parCpt <> 0 Then
            ' if depth par n-1 is equal to n's & line number from n-1 is right before n's
            If par(parCpt - 1, 2) = par(parCpt, 2) And par(parCpt - 1, 0) + 1 = par(parCpt, 0) Then
                ' copy to n-1 & don't incr parCpt
                par(parCpt - 1, 0) = par(parCpt, 0)
                par(parCpt - 1, 1) = par(parCpt, 1)
                par(parCpt - 1, 2) = par(parCpt, 2)
                par(parCpt - 1, 3) = par(parCpt, 3)
            Else: parCpt = parCpt + 1
            End If
        Else: parCpt = parCpt + 1
        End If
    Wend

    For i = 1 To maxDepth                   ' Applying paragraph numbers depth by depth
        cpt = 0                                 ' init at 0 so turns to 1 first time, which is what needed
        For j = 0 To parCpt
            If i > par(j, 2) Then cpt = 0           ' a sub paragraph end reached (resetting current and follow)
            If i = par(j, 2) Then cpt = cpt + 1     ' a new paragraph is reached (increment current and follow)
            If i <= par(j, 2) Then                  ' paragraph depth need to be added to sting
                If i <> 1 Then par(j, 1) = par(j, 1) & "."      ' dot added only if sub paragraph
                par(j, 1) = par(j, 1) & cpt                     ' append paragraph number to string in tab
            End If
        Next j
    Next i
End Sub