[Word] Macro ignoriert Nummerierung

Nico25394 · 28. März 2014

Hi,

also ich versuche derzeit die Überschriften in einem Word Dokument in Textmarken umzuwandeln,
dazu habe ich in einem leider bereits ziemlich ausgestorbenen Forum den unten dargestellten Code gefunden.

Grundsätzlich bin ich auch sehr zufrieden mit dem Ergebnis, jedoch werden Nummerierungen nicht berücksichtigt (was erstmal nicht schlimm ist). Gleichzeitig entstehen dadurch jedoch Doppelungen bei den Überschriften, welche daraufhin übersprungen werden.
Ich kenne mich leider mit Macros bzw. VBA nicht wirklich aus, daher bitte ich euch hiermit um hilfe

MFG Nico

Code:

Option Explicit 
Sub HeadingsToBookmarks() 
Dim BM As Bookmark, t_rng As Range 
Dim i As Integer 
Dim oDoc As Document 
Dim sBM As String, bFound As Boolean 
Dim rng As Range 
Dim aBM() As String 

Dim r_Kap As Range 
    
' Aktives Dokument 
Set oDoc = ActiveDocument 
' Keine versteckten Textmarken anzeigen 
ActiveDocument.Bookmarks.ShowHidden = False 
If Len(Selection) > 1 Then 
  TextToBookmark 
  Exit Sub 
End If 
' 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(wdStyleHeading4), _ 
        oDoc.Styles("Inhaltsverzeichnis")  ', oDoc.Styles("Anhang2"), oDoc.Styles("Anhang3") 
        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? 
         t_rng.Select 
        Debug.Print t_rng.Bookmarks("\Line").Range.Text 
        If t_rng.Text = Replace(t_rng.Bookmarks("\Line").Range.Text, Chr(13), "") Then 
          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 fkt_CorrektBookmark(sBM), t_rng 
              End If 
  '          Else 
  '              oDoc.Bookmarks.add fkt_CorrektBookmark(sBM), t_rng 
          Else 
            ' Keine Textmarke vorhanden, dann neu setzen 
            oDoc.Bookmarks.Add fkt_CorrektBookmark(sBM), t_rng 
          End If 
        End If 
        Exit Do 
    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 fkt_CorrektBookmark(sBM), t_rng 
            End If 
          Else 
            ' Keine Textmarke vorhanden, dann neu setzen 
            oDoc.Bookmarks.Add fkt_CorrektBookmark(sBM), t_rng 
          End If 
          Exit Do 
      End Select 
      .Execute 
    Loop 
  End With 
Next i 
End Sub 
Property Get fkt_CorrektBookmark(ByVal sText As String) As String 
Dim i As Integer 
Const c_Allowed = "_abcdefghijklmnopqrstuvwxyz" 
Const c_NotAllowed = ".!§$%&/()?`´" 
Dim t_Text As String 
t_Text = Trim(sText) 
  Do While InStr(1, c_Allowed, LCase(Left(t_Text, 1))) = 0 
    t_Text = Right(t_Text, Len(t_Text) - 1) 
  Loop 
  t_Text = Replace(Trim(t_Text), " ", "_") 
  t_Text = Replace(Trim(t_Text), Chr(150), "_") 
  t_Text = Replace(Trim(t_Text), Chr(160), "_") 
  t_Text = Replace(Trim(t_Text), Chr(34), "_") 
  t_Text = Replace(Trim(t_Text), Chr(147), "_") 
  t_Text = Replace(Trim(t_Text), Chr(132), "_") 
  t_Text = Replace(Trim(t_Text), Chr(31), "") 
  t_Text = Replace(Trim(t_Text), "'", "") 
  t_Text = Replace(Trim(t_Text), ":", "") 
  t_Text = Replace(Trim(t_Text), "+", "") 
  For i = 1 To Len(c_NotAllowed) 
    t_Text = Replace(t_Text, Mid(c_NotAllowed, i, 1), "_") 
  Next i 
If t_Text = "" Then t_Text = "_ungueltig_" & Val(Timer) 
fkt_CorrektBookmark = t_Text 
End Property 


Sub TextToBookmark() 
Dim Sel As Selection, sBM As String 
Dim oDoc As Document 
Set oDoc = ActiveDocument 
Set Sel = Selection 
    If IsNumeric(Left(Sel, 1)) = True Then 
      Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(Sel, 1))) = 0 
        Sel = Right(Sel, Len(Sel) - 1) 
      Loop 
    End If 
    sBM = fktCheckString(Sel.Text) 
    If Sel.Bookmarks.Count > 0 Then 
    ' wenn ja und abweichend vom Namen dann löschen 
      If Sel.Bookmarks(1).Name <> sBM Or Len(Sel.Bookmarks(1).Range) <> Len(Sel.Text) Then 
        Sel.Bookmarks(1).Delete 
        ' Textmarke neu setzen 
        oDoc.Bookmarks.Add fkt_CorrektBookmark(sBM), Sel 
      End If 
    Else 
      ' Keine Textmarke vorhanden, dann neu setzen 
      oDoc.Bookmarks.Add fkt_CorrektBookmark(sBM), Sel 
    End If 
End Sub 
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

morcego · 28. März 2014

Gibt es einen bestimmten Grund wieso du da Textmarken benötigst?
Programmieren sehe ich eher als Lösung wenn das Programm was selber nicht kann oder Abläufe sonst nicht greifbar sind.

Nico25394 · 31. März 2014

Ja die Textmarken brauche ich, da ich sonst das Dokument nicht entsprechend in ein PDF umwandeln kann.
Ich muss beim PDF Aufruf zu bestimmten Stellen (den Überschriften bzw im PDF den Lesezeichen) springen können, das ist jedoch nur mit Marked destinations möglich und um diese dementsprechend zu erhalten muss man die Textmarken setzen, da das jedoch öfter angewendet werden muss, sollte ich da eine Automatische Lösung haben, um die Marken nicht von Hand setzen zu müssen.

LG Nico

morcego · 31. März 2014

Sehe ich persönlich keinen Sinn drin. Sowohl der seit 2007 vorhandene PDF-Export kann die Überschriften automatisch in Lesezeichen wandeln, als auch Aufsätze wie Acrobat. Drucken ist in allen Fällen der falsche Weg.

Nico25394 · 1. April 2014

ich will das ganze auch nicht drucken, sondern im PDF bestimmte Punkte ansteuern und das geht wohl nur über named destinations, diese kann man entweder durch acrobat setzen lassen (nicht den reader) oder bei einem export durch Open Office.
Acrobat habe ich nicht und beim OO export werden nur Textmarken als named destinations exportiert, welche man entweder von hand (was keine option ist) oder per makro setzen kann. Da die Dokumente eigentlich immer in .doc form vorliegen, wollte ich dann ein Word makro, welche alle Überschriften automatisch umwandelt. Aber hier bin ich auf das oben beschriebene Problem gestoßen

morcego · 1. April 2014

Ja wie gesagt, macht der Word PDF-Export auch.

Suche

[Word] Macro ignoriert Nummerierung

Nico25394

Lieutenant

morcego

Lt. Commander

Nico25394

Lieutenant

morcego

Lt. Commander

Nico25394

Lieutenant

morcego

Lt. Commander

Ähnliche Themen