Option Explicit
Sub KommentarAbsatznummer()
->** für jeden Kommentar erfolgt eine Meldung mit:
->** - Kommentarnummer
->** - Kommentar
->** - Absatznummer
->** - Absatznummerierung der nächsten darüberliegenden Überschrift
->** - Überschrift der nächsten darüberliegenden Überschrift
Dim kom As Comment, l_kom As Long, t As String, t2 As Long, n As Long
Dim s_Ueberschrift As String, s_Ueberschrift_full As String
Dim l_ParagrahenNummer As Long, s_ParNum As String
Dim doc As Document, x As Long, s As Long, h As Long, l_num As Long
Dim f_style(1 To 9) As Long, l_start As Long, l_end As Long
->Feld der Überschriften-Styles
f_style(1) = wdStyleHeading1
f_style(2) = wdStyleHeading2
f_style(3) = wdStyleHeading3
f_style(4) = wdStyleHeading4
f_style(5) = wdStyleHeading5
f_style(6) = wdStyleHeading6
f_style(7) = wdStyleHeading7
f_style(8) = wdStyleHeading8
f_style(9) = wdStyleHeading9
Set doc = ActiveDocument
->alle Kommentare
For Each kom In ActiveDocument.Comments
->Kommentar selektieen
kom.Scope.Select
->betreffende Paragrahennummer feststellen
l_ParagrahenNummer = doc.Range(Start:=1, End:=Selection.End).Paragraphs.Count
->nächst höhergelegene Überschrift suchen
s_ParNum = kein Überschriften Absatz vor dem Kommentar
For x = l_ParagrahenNummer To 1 Step -1
For s = LBound(f_style()) To UBound(f_style())
->Paragraph mit Überschriften-Format ?
If doc.Paragraphs(x).Style = doc.Styles(f_style(s)) Then
->Überschrift gefunden
->Überschrift lesen
s_Ueberschrift_full = doc.Paragraphs(x).Range.Text
s_Ueberschrift =
->Schmierzeichen ausblenden
For n = 1 To Len(s_Ueberschrift_full)
t = Mid(s_Ueberschrift_full, n, 1)
t2 = Asc(t)
Select Case t2
Case 0 To 31
Case Else
s_Ueberschrift = s_Ueberschrift & t
End Select
Next
->automatische Nummerierung des Absatzes prüfen
On Error Resume Next
s_ParNum =
->dies sollte eigentlich das Nummerierungsfeld als Text liefern
s_ParNum = doc.Paragraphs(x).Range.Fields(1).Result.Text
If Err.Number <> 0 Then
->Überschrift ohne Feld automatische Nummerierung
Err.Clear
s_ParNum = Überschrift gefunden, aber keine automatische Nummerierung
On Error GoTo 0
GoTo Ergebnis
End If
->Überschrift mit automatischer Nummerierung gefunden
->Nummerierung kann aber nicht mittels Result.Text ermittelt werden
->-> Nummerierung zu Fuß ermitteln
->Suchbereich Überschrift-Paragraph bis Doc-Anfang setzen
l_start = doc.Paragraphs(1).Range.Start
l_end = doc.Paragraphs(x).Range.End
s_ParNum =
->für Überschrift-Stil 1 bis zu dem des gefundenen Überschriften-Paragraphen
For h = 1 To s
->relevanten Suchbereich setzen
doc.Range(Start:=l_start, End:=l_end).Select
->Anzahl der Paragraphen mit betreffendem Überschriften-Stil
With Selection.Find
.ClearFormatting
.Style = f_style(h)
.Forward = True
.Format = True
.Wrap = wdFindStop
.Text =
l_num = 0
Do While Selection.Find.Execute() = True
->Wenn Fundstelle nach dem Betreffenden Uberschriften-Paragraphen,
->dann weiter Suche abbrechen
If Selection.End > l_end Then Exit Do
->Überschriften zählen
l_num = l_num + 1
->nächsten Suchbereichsanfang hinter die Fundstelle setzen
l_start = Selection.End + 1
->Suchbereich auf beschränkten Bereich setzen
doc.Range(Start:=l_start, End:=l_end).Select
Loop
End With
->Anzahl der gefundenen Überschriften als Nummerierung anfügen
s_ParNum = s_ParNum & l_num & .
Next
GoTo Ergebnis
End If
Next
Next
Ergebnis:
->*** Ergebnis für diesen Kommentar ausgeben
l_kom = l_kom + 1->Kommentar zählen
kom.Scope.Select ->Kommentar selektieren
MsgBox ( _
Kommentar Nr. & l_kom & vbCrLf & vbCrLf & _
Kommentar : & vbCrLf & kom.Range.Text & vbCrLf & vbCrLf & _
Absatznummer: & l_ParagrahenNummer & vbCrLf & _
In Abschnitt: & s_ParNum & vbCrLf & _
Überschrift : & s_Ueberschrift)
Next
Aufraeumen:
Set kom = Nothing: Set doc = Nothing
End Sub