nappi90
10-01-2014, 02:50 AM
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!
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!
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!
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!