Part 2: Audit words in Sample file (using vba in Access 2016)

In the Part 1 one of this question,  als315 helped me to populate [word] column where each word contained in a sample doc file is recorded separately in a new row.
 
For this question, I have a 3-page sample doc file and the word column is handled perfectly via the attached MS Access database. Both DB and the sample DB files are attached. The sample doc file is kept in the DB folder.

Question: In addition to item 1 below, could you possibly help me to read items 2 through 6 from the doc file? I have included the portion of the vba code recording the [Word] column which could be modified to do the rest. I also, have included the database itself in case you are more comfortable doing it by trial and error.
 
1- Word (Already Done).
2- PageNo (Must Have this one)
3- ParagraphNo (Optional, if you can do it)
4- LineNoInThePage (Optional, if you can do it)
5- LineNoInTheParagraph (Optional, if you can do it)
6- ChapterNo (Must Have this one)

Option Compare Database
Dim wrd As Object
Dim iByPass As Integer
Private Sub cmdStart_Click()
Dim objWord As Object
Dim doc As Object
Dim parag As Object
Dim par As Object
Dim sents As Object
Dim sent As Object
Dim wrds As Object
'Dim wrd As Object
Dim path As String
Dim p As Long, w As Long
Dim chapt As Long
Dim s As String
Dim sn As Long
path = CurrentProject.path & "\SampleText.docx" ' docx should be in DB's path
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Err.Number = 429 Then
    'If we got an error, that means there was no Word Instance
    Set objWord = CreateObject("Word.Application")
End If
On Error GoTo 0
DoCmd.RunCommand acCmdDebugWindow
objWord.Visible = True
Set doc = objWord.Documents.Open(path)
Set parag = doc.Paragraphs
p = 0
For Each para In parag  'Loop across paragraphs
        p = p + 1
        Set sents = para.Range.Sentences        'loop across sentences
        
        For Each sent In sents
           For Each wrds In sent.Words         ' loop across words
                Set wrd = wrds
                wrd.Select
                s = doc.ActiveWindow.ActivePane.Selection.Sections.Last.Headers.Item(1).Range.Text
                s = Mid(s, 8, 3)
                chapt = CLng(s)

                If Len(Trim(wrd)) >= 3 Then
                    CurrentDb.Execute ("insert into IndexLevel_1(Word) values(" & Chr(34) & Trim(wrd) & Chr(34) & ")"), dbFailOnError
                    Call Progress
                End If

            Next
        Next
Next
doc.Close
objWord.Application.Quit
Me!lblProgress.Caption = "Done!"
End Sub

Private Sub Progress()
'If iByPass = 0 Or iByPass = 5 Or iByPass = 10 Or iByPass = 15 Or iByPass = 20 Or iByPass = 25 Or iByPass = 30 Or iByPass = 35 Or iByPass = 40 Then
Me!lblProgress.Caption = wrd
Me!lblProgress.Visible = Not (Me!lblProgress.Visible)
Me.Repaint
'End If
iByPass = iByPass + 1
End Sub

Select allOpen in new window

SampleText.docx
DBIndex.accdb