Analysing a Word Documents headings and write it in an array

Hey i wanna analyse a documents headings and put them into a 3-dimensional array.
So that i always know which heading belongs to which chapter... Can you help me?

e.g.:

1 Hello
1.1 Helloo
1.2 Helloo2
1.1.1 Hellooo
2 Bye
2.1 Byee
2.1.1 Byeee

array:
1 2 3
1 Hello Helloo Hellooo
Helloo2
2 Bye Byee Byeee



my code is not working yet. Headinglevel 1 is working... but the rest is not... and i dont know why!

Code:

---

Sub testoe()
Dim WordApp As Object
Dim Rng As Word.Range
Dim Rng1 As Word.Range
Dim Rng2 As Word.Range
Dim kapNr1 As Integer
Dim kapNr2 As Integer
Dim kapNr3 As Integer


Dim kapitel(40, 150, 150) As String
kapNr1 = 1
kapNr2 = 1
kapNr3 = 1
Set WordApp = CreateObject("Word.Application")

    With WordApp
        .Documents.Open ("Test.doc")
        .Visible = True
        End With
       
        Set Rng = WordApp.ActiveDocument.Content
        Rng.Find.Style = wdStyleHeading1
        Rng.Find.Execute
        Do While Rng.Find.Found = True
        Rng.Find.Style = wdStyleHeading1
        Rng.Select
        WordApp.Selection.Copy
        kapitel(kapNr1, 0, 0) = clipboard2String
        kapNr1 = kapNr1 + 1
                       
            Set Rng1 = Rng.Duplicate
            Rng1.Find.Style = wdStyleHeading2
            Rng1.Find.Execute
            Do While Rng1.Find.Found = True
            Rng1.Find.ClearFormatting
            Rng1.Find.Style = wdStyleHeading2
            Rng1.Select
            WordApp.Selection.Copy
            kapitel(kapNr1, kapNr2, 0) = clipboard2String
            kapNr2 = kapNr2 + 1
               
                Set Rng2 = Rng1.Duplicate
                With Rng2.Find
                .Style = wdStyleHeading3
                .Execute
                Do While .Found = True
                .Style = wdStyleHeading3
                Rng2.Select
                WordApp.Selection.Copy
                kapitel(kapNr1, kapNr2, kapNr3) = clipboard2String
                kapNr3 = kapNr3 + 1
                .Execute Forward:=True
               
                Loop
                End With
                kapNr3 = 1
                Rng1.Find.Execute Forward:=True
            Loop
            kapNr2 = 1
           
    Rng.Find.Execute Forward:=True
    Loop
       
     
        'WordApp.ActiveDocument.Saved = False
        WordApp.Application.Quit
       
       
    MsgBox kapitel(1, 1, 0), vbInformation, "Hinweis"

End Sub

---

Hope you can help me! Thanks!

We can help you even better if you post a sample Word document.

Quote:

---

Originally Posted by snb

We can help you even better if you post a sample Word document.

---

Did you consider inserting a table of contents in the document ?

Code:

---

Sub M_snb()
    Application.Templates("C:\Documents and Settings\***\Application Data\Microsoft\Document Building Blocks\1033\14\Built-In Building Blocks.dotx").BuildingBlockEntries("Automatic Table 2").Insert Selection.Range, True
End Sub

---