Sysfilter Homepage

Option Explicit



'************************************************

'* Bookmark Makro

'* Bookmark_Start: Search for all REF bookmarks in active Word document and converts them to format "tw4wininternal"

'* Bookmark_Back: Creates bookmarks again

'* For free use. Use at your own risk.

'* Copyright by ECM engineering, Wilhelm Polmann

'* Questions? -> info@sysfilter.de

'************************************************





Dim Textmarke As String

             



Sub Bookmark_Start()



Dim i As Long

Dim aBookmark As Bookmark

Dim Counter As Long

Dim aMarcs As String

' Dim aBookmark As Bookmark



Do While Documents.count >= 1



'Application.Run MacroName:="sAddTagStyles"



' or



Addtw4winInternalStyle







' Überarbeitung deaktivieren

ActiveDocument.TrackRevisions = False



' Alle Änderungen annehmen

WordBasic.AcceptAllChangesInDoc



ActiveDocument.Bookmarks.ShowHidden = True

'Dialogs(wdDialogInsertBookmark).Show





'Alle Felder Anzeigen lassen



'Debug.Print "es sind " & ActiveDocument.Bookmarks.count & " Bookmarks vorhanden. "





If ActiveDocument.Bookmarks.count >= 1 Then

    ReDim aMarks(ActiveDocument.Bookmarks.count - 1)

    i = 0

    For Each aBookmark In ActiveDocument.Bookmarks

        aMarks(i) = aBookmark.Name

        Textmarke = aMarks(i)

        

        If (InStr(Textmarke, "_Toc") = 0) Then

            bmk2tw4win

        End If

        i = i + 1

    

    Next aBookmark

End If



ActiveDocument.Save

ActiveDocument.Close



Loop









End Sub





Sub bmk2tw4win()

    

Dim AnfangAT As Long

Dim AnfangET As Long

Dim EndeAT As Long

Dim EndeET As Long



Dim oRange As Range



'*************************

'Bookmark Anfang markieren 'Anfang-tag

'*************************

    

    ActiveDocument.Bookmarks("" & Textmarke & "").Select

    'nach links springen, falls Bookmark mitten im Wort

    'Selection.MoveLeft Unit:=wdWord, Count:=1  wp 08.2009

    'Selection.MoveLeft Unit:=wdCharacter, Count:=1

    

'Bereich definieren und Format zuweisen

    

    AnfangAT = Selection.Start

        

    ' wenn Bookmarkbereich Text enthält

    If Len(Selection.Text) > 0 Then

        Selection.MoveLeft Unit:=wdCharacter, count:=1

    End If

    

    

    Selection.TypeText Text:="<<<BM_S>>>" & """" & Textmarke & """"

    EndeAT = Selection.End

    

' Formatvorlage zuweisen 'Anfang-tag

    Set oRange = ActiveDocument.Range(AnfangAT, EndeAT)

    oRange.Select

    Selection.Style = ActiveDocument.Styles("tw4wininternal")





    

'*************************

'Bookmark Ende markieren 'Ende-tag

'*************************

    

    ActiveDocument.Bookmarks("" & Textmarke & "").Select



    'nach rechts springen, falls Bookmark mitten im Wort

    ' Selection.MoveRight Unit:=wdWord, Count:=1 ' wp 08.2009

    'Selection.MoveLeft Unit:=wdCharacter, Count:=1

    

    'Bookmark-Bereich Ende

    'Selection.MoveRight Unit:=wdCharacter, Count:=1

    

    ' wenn Bookmarkbereich Text enthält

    If Len(Selection.Text) > 1 Then

        Selection.MoveRight Unit:=wdCharacter, count:=1

    End If



    AnfangET = Selection.Start

    

    'Wenn Referenzmarke ohne Inhalt bzw. Gleichen Start und Endepunkt hat

    If AnfangAT = AnfangET Then

        Selection.Find.Execute FindText:="<<<BM_S>>>" & """" & Textmarke & """", Forward:=True

        AnfangET = Selection.End

        Selection.MoveRight Unit:=wdCharacter, count:=1

    End If

    

    Selection.TypeText Text:="<<<BM_E>>>" & """" & Textmarke & """"

    EndeET = Selection.End

    

    Set oRange = ActiveDocument.Range(AnfangET, EndeET)

    oRange.Select

    Selection.Style = ActiveDocument.Styles("tw4wininternal")

    

    

'*************************

'Bookmark löschen

'*************************

    ActiveDocument.Bookmarks("" & Textmarke & "").Delete

    With ActiveDocument.Bookmarks

        .DefaultSorting = wdSortByName

        .ShowHidden = True

     

    End With

 



 

    

End Sub





Sub Bookmark_Back()



Dim neue_Textmarke As String

Dim Anfang As Long

Dim Ende As Long



Dim VorgAnfang As Long

Dim VorgEnde As Long



Dim oRange As Range



    'On Error GoTo ErrorHandler



    Selection.EndKey Unit:=wdStory

    'Selection.HomeKey Unit:=wdStory





   

Do



    

'Bookmarknamen finden

    Selection.Find.ClearFormatting

    With Selection.Find

        .Text = "<<<BM_S>>>"""

        .Replacement.Text = ""

        .Forward = False

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With



 Selection.Find.Execute

        

 If Selection.Text <> "<<<BM_S>>>""" Then Exit Do

 

        Selection.Delete

                    

        Selection.MoveEndUntil Cset:=""""

            

            neue_Textmarke = Selection.Text

         

         ' Bookmark Startpunkt definieren

        

                Selection.MoveRight Extend:=wdExtend

                Selection.Delete

                'Selection.MoveRight Unit:=wdCharacter, Count:=1

                Anfang = Selection.Start

               

         ' Bookmark Endpunkt definieren



                Selection.Find.Execute FindText:="<<<BM_E>>>""" & neue_Textmarke & """", Forward:=True

                Selection.Delete

                Ende = Selection.End

            

 ' Bookmark wird wieder hinzugefügt

   Set oRange = ActiveDocument.Range(Anfang, Ende)

           

            With ActiveDocument.Bookmarks

                .Add Range:=oRange, Name:=neue_Textmarke

                .DefaultSorting = wdSortByName

                .ShowHidden = True

                VorgAnfang = Anfang

                VorgEnde = Ende

        End With

Selection.MoveLeft Unit:=wdCharacter, count:=1



Loop



ActiveDocument.Bookmarks.ShowHidden = True

'Debug.Print "es sind " & ActiveDocument.Bookmarks.count & " Bookmarks vorhanden. (tw4win2bmk)"





Exit Sub



ErrorHandler:



Selection.HomeKey Unit:=wdStory

    

    Selection.Find.ClearFormatting

    With Selection.Find

        .Text = "<<<BM_S>>>"""

        .Replacement.Text = ""

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With



Selection.Find.Execute



If Selection.Find.Execute = False Then

        MsgBox "Bookmarks konvertiert, trotzdem BM Liste kurz durchchecken. / Ready. Check Bookmark list."

    Else

        MsgBox "Anscheinend sind nicht alle Bookmarks konvertiert worden!!! / Some bookmarks not converted.", vbCritical

End If





End Sub



Sub Addtw4winInternalStyle()





    Dim oStyle As Word.Style



    For Each oStyle In ActiveDocument.Styles

        If oStyle.NameLocal = "tw4winInternal" Then Exit Sub

    Next

    

    'ActiveDocument.Parent.Application.Visible = False

    ActiveDocument.Activate

    ActiveDocument.Windows(1).View.ShowFieldCodes = True

    ActiveDocument.Words(1).Select

    ActiveDocument.Styles.Add "tw4winInternal", 2 ' wdStyleTypeCharacter

    ActiveDocument.Styles("tw4winInternal").Font.Name = "Courier New"

    ActiveDocument.Styles("tw4winInternal").Font.ColorIndex = 6 ' wdRed

    ActiveDocument.Styles("tw4winInternal").LanguageID = 1024 ' wdNoProofing

    'ActiveDocument.Parent.Application.Visible = True

   

            

End Sub