Überschriften zu Textmarken wandeln

Aktuelle Seite:
/vba/vbaHeadingToBookmark.htm

Letzte Änderung: 22.10.2009

Fügt man in einer Datei einen Querverweis auf eine Überschrift mit Word-Funktionen ein, verwendet Word versteckte Textmarken (beginnend mit einem Unterstrich) nach einem internen Schema (_Ref<9 Zahlen>) anstelle von selbstsprechenden Namen. Treten später mal Probleme mit den Verweisen auf, lässt sich nur schwer der Originalbezug ermitteln.

Genau an dieser Stelle treten die bereitgestellen Makros in Aktion: Sie setzen auf alle Überschriften, sofern sie mit einer Gliederungsebene versehen sind, eine gleichnamige Textmarke. Nicht erlaubte Zeichen im Textmarkennamen werden dabei durch Ersatzzeichen ersetzt. So dürften Textmarken z.B. nur mit Buchstaben und dem Unterstrich anfangen und im Namen keine Leerzeichen, Sonderzeichen, Bindestriche, Anführungszeichen, Klammern etc. besitzen.

Desweiteren wird überprüft, ob die Überschrift bereits eine nicht-versteckte Textmarke besitzt bzw. ob die Länge des Textmarkeninhalts abweichend von der Länge der Überschrift ist. In diesen Fällen wird die Textmarke neu gesetzt.

Zur Umsetzung stehen verschiedene Ansätze zur Verfügung, die jeweils Vor- ud Nachteile besitzen:
Das Durchlaufen aller Absätze:

erfasst alle Überschriften mit Gliederungsebene

braucht bei umfangreichen Dokumenten länger

Die Verwendung der in Word zur Verfügung stehenden Querverweiseinträge:

läuft deutlich schneller

erfasst keine eigenen Formatvorlage mit Gliederungsebenen, wenn keine Nummerierung verwendet wird

Im Folgenden wird zuerst die vollständige Version vorgestellt:
Dazu werden alle Absätze (Paragraphs) durchlaufen und die OutlineLevel-Eigenschaft (Gliederungsebene) überprüft, ob sie ungleich der Textebene ist wdOutlineLevelBodyText. In dem Fall wird der Überschriftstext in einen gültigen Textmarkennamen umgewandelt.

Sub SearchOutlineLevel()  
Dim oPara As Paragraph
Dim rng As Range
Dim t_range As Range
Dim oDoc As Document
Set oDoc = ActiveDocument
oDoc.Bookmarks.ShowHidden = False
For Each oPara In oDoc.Paragraphs
  With oPara
    Set rng = .Range
    If .Range.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText Then
      Select Case .Range.ParagraphFormat.OutlineLevel
      Case 1 To 9
        Set t_rng = rng.Duplicate
        ' Absatzmarken in der Überschrift?  
        If InStr(1, t_rng, Chr(13)) > 0 Then
          t_rng.End = t_rng.End - Len(Chr(13))
        End If
        ' Korrekte Textmarkennamen erzeugen  
        sBM = fktCheckString(t_rng.Text)
        ' Besitzt die Überschrift schon eine Textmarke?  
        If t_rng.Bookmarks.Count > 0 Then
        ' wenn ja und abweichend vom Namen dann löschen  
          If t_rng.Bookmarks(1).Name <> sBM Or Len(t_rng.Bookmarks(1).Range) <> Len(t_rng.Text) Then
            t_rng.Bookmarks(1).Delete
            ' Textmarke neu setzen  
            oDoc.Bookmarks.add sBM, t_rng
          End If
        Else
          ' Keine Textmarke vorhanden, dann neu setzen  
          oDoc.Bookmarks.add sBM, t_rng
        End If
      End Select
    End If
  End With
Next oPara
End Sub

Die Funktion fktCheckString() wertet dabei die übergebene Zeichenkette aus und liefert einen gültigenTextmarkennamen zurück:

Function fktCheckString(sText As String) As String  
  If IsNumeric(Left(sText, 1)) = True Then
    Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(sText, 1))) = 0
      sText = Right(sText, Len(sText) - 1)
    Loop
  End If
  ' Nichterlaubte Zeichen filtern  
  sText = Replace(sText, " ", "_")
  sText = Replace(sText, Chr(13), "")
  sText = Replace(sText, ".", "")
  sText = Replace(sText, "-", "_")
  sText = Replace(sText, "/", "_")
  sText = Replace(sText, "&", "_")
  sText = Replace(sText, "<", "_")
  sText = Replace(sText, ">", "_")
  sText = Replace(sText, Chr(34), "")
  fktCheckString = sText
End Function

Der Weg über die Querverweiseinträge durchläuft zuerst alle Einträge, die in dem Verweistyp Überschrift aufgelistet werden, anschließend alle Einträge, die in dem Verweistyp Nummeriertes Element aufgeführt sind. Hier wird auch der Nachteil dieser Auswertung ersichtlich, da nichtnummerierte eigene Gliederungsformatvorlage unter diesem Verweistyp nicht aufgelistet werden. Die gefunden Verweisstellen werden dabei wie in der ersten Variante wieder ausgewertet und mit Textmarken versehen.

Sub HeadingsToBookmarks()  
Dim BM As Bookmark, t_rng As Range
Dim i As Integer
Dim oDoc As Document
Dim strBM As String, bfound As Boolean
Dim rng As Range
Dim aBM() As String
' Aktives Dokument  
Set oDoc = ActiveDocument
' Keine versteckten Textmarken anzeigen  
ActiveDocument.Bookmarks.ShowHidden = False
' Alle Querverweise für Überschriften  
aBM() = oDoc.GetCrossReferenceItems(wdRefTypeHeading)
For i = LBound(aBM()) To UBound(aBM())
  Set rng = oDoc.Content
  With rng.Find
    'Überschriften suchen  
    .Text = Trim(aBM(i))
    ' evtl. Überschriftennummierung entfernen  
    If IsNumeric(Left(.Text, 1)) = True Then
      Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(.Text, 1))) = 0
        .Text = Right(.Text, Len(.Text) - 1)
      Loop
    End If
    .MatchCase = True
    .MatchWholeWord = True
    .Execute
    ' Wurde ein Verweistext gefunden?  
    Do While .Found = True
      'rng.Select  
      Select Case rng.Style
      Case oDoc.Styles(wdStyleHeading1), _
        oDoc.Styles(wdStyleHeading2), _
        oDoc.Styles(wdStyleHeading3), _
        oDoc.Styles(wdStyleHeading4), _
        oDoc.Styles(wdStyleHeading5)
        Set t_rng = rng.Duplicate
        ' Absatzmarken in der Überschrift?  
        If InStr(1, t_rng, Chr(13)) > 0 Then
          t_rng.End = t_rng.End - Len(Chr(13))
        End If
        ' Korrekte Textmarkennamen erzeugen  
        sBM = fktCheckString(t_rng.Text)
        ' Besitzt die Überschrift schon eine Textmarke?  
        If t_rng.Bookmarks.Count > 0 Then
        ' wenn ja und abweichend vom Namen dann löschen  
          If t_rng.Bookmarks(1).Name <> sBM Or Len(t_rng.Bookmarks(1).Range) <> Len(t_rng.Text) Then
            t_rng.Bookmarks(1).Delete
            ' Textmarke neu setzen  
            oDoc.Bookmarks.add sBM, t_rng
          End If
        Else
          ' Keine Textmarke vorhanden, dann neu setzen  
          oDoc.Bookmarks.add sBM, t_rng
        End If
    End Select
    .Execute
    Loop
  End With
Next i
weiter:
' Überschriften, die nicht mit den Standardformatvorlagen formatiert sind  
aBM() = oDoc.GetCrossReferenceItems(wdRefTypeNumberedItem)
For i = LBound(aBM()) To UBound(aBM())
  Set rng = oDoc.Content
  With rng.Find
    .Text = Trim(aBM(i))
    ' evtl. Überschriftennummierung entfernen  
    If IsNumeric(Left(.Text, 1)) = True Then
      Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(.Text, 1))) = 0
        .Text = Right(.Text, Len(.Text) - 1)
      Loop
    End If
    .MatchCase = True
    .MatchWholeWord = True
    .Execute
    ' Wurde ein Verweistext gefunden?  
    Do While .Found = True
    'rng.Select  
    Select Case rng.ParagraphFormat.OutlineLevel
    Case 1 To 9
        Set t_rng = rng.Duplicate
        ' Absatzmarken in der Überschrift?  
        If InStr(1, t_rng, Chr(13)) > 0 Then
          t_rng.End = t_rng.End - Len(Chr(13))
        End If
        ' Korrekte Textmarkennamen erzeugen  
        sBM = fktCheckString(t_rng.Text)
        ' Besitzt die Überschrift schon eine Textmarke?  
        If t_rng.Bookmarks.Count > 0 Then
        ' wenn ja und abweichend vom Namen dann löschen  
          If t_rng.Bookmarks(1).Name <> sBM Or Len(t_rng.Bookmarks(1).Range) <> Len(t_rng.Text) Then
            t_rng.Bookmarks(1).Delete
            ' Textmarke neu setzen  
            oDoc.Bookmarks.add sBM, t_rng
          End If
        Else
          ' Keine Textmarke vorhanden, dann neu setzen  
          oDoc.Bookmarks.add sBM, t_rng
        End If
    End Select
    .Execute
    Loop
  End With
Next i
End Sub