Absatznummer für Kommentar-Fundstelle

Sub KommentarAbsatznummer()
  Dim kom As Comment
  For Each kom In ActiveDocument.Comments
    kom.Scope.Select
    l_ParagrahenNummer = ActiveDocument.Range(Start:=pos, End:=Selection.End).Paragraphs.Count
  Next
End Sub

  Dim com As Comment
  Dim r As Range

  For i = 1 to doc1.Comments.Count
    Set com = doc1.Comments.Item(i)
    Set r = com.Scope
    r.GoTo what:=wdGoToHeading, which:=wdGoToPrevious, Count:=1
    r.Expand unit:=wdSentence
    MsgBox Kapitelüberschrift= & r.Text
  Next

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