Option Explicit 'Werner Roth 'Stattet einen HTML-Text mit Textankern aus (das sind StarWriter-Textmarken) . 'Es werden alle Überschriftsebenen durchsucht und jede Überschrift mit einer Textmarke versehen 'Diese Textmarke wird aus dem Inhalt der Überschrift erzeugt. 'Dabei werden Umlaute, Leerzeichen, u.ä. konvertiert. Dim oActiveWindow As Object Sub MakeHTMLAnchors Dim StrSearchForWhat As String oActiveWindow = ActiveWindow 'Suchoptionen setzen With oActiveWindow.SearchSettings .Backward = False .InSelection = False .Pattern = True 'Suche nach Vorlagen einschalten End With 'Erzeuge Anker/Textmarken für alle Überschriftsebenen MakeHTMLAnchorsFind("Überschrift 1") MakeHTMLAnchorsFind("Überschrift 2") MakeHTMLAnchorsFind("Überschrift 3") MakeHTMLAnchorsFind("Überschrift 4") MakeHTMLAnchorsFind("Überschrift 5") 'Setze an den Anfang und das Ende eines Texte eine Textmarke With oActiveWindow .JumpToStartOfDoc() If not MakeHTMLAnchorsFoundBookmark("Begin") Then .InsertBookmark( "Begin" ) End If .JumpToEndOfDoc() If not MakeHTMLAnchorsFoundBookmark("End") Then .InsertBookmark( "End" ) End If End With End Sub Sub MakeHTMLAnchorsFind(StrSearchForWhat As String) 'Suche jeweils nach einer Absatzvorlage und füge am anfang des Absatzes eine Textmarke ein. 'Der Name der Textmarke ist der Inhalt des Absatzes. Dim StrBookMarkName As String With oActiveWindow 'Fange ganz oben an .JumpToStartOfDoc() 'Nun klappere jede Fundstelle ab Do While .Search(StrSearchForWhat) 'Erzeuge aus dem Inhalt des Absatzes eine vernünftige Textmarke StrBookMarkName = MakeHTMLAnchorsBookmark(oActiveWindow.Value()) 'Füge diese Textmarke am Anfang des Absatzes ein und springe an dessen Ende '(damit die Suche weitergehen kann) .GoToStartOfPara( False ) .InsertBookmark( StrBookMarkName ) .GoToEndOfPara( False ) Loop End With End Sub Function MakeHTMLAnchorsBookmark(StrText As String) 'Erzeuge aus gegebenen Text eine vernünftige Textmarken-Bezeichnung 'Wandle alle nicht sinnvollen Zeichen für so etwas um Dim i As Integer Dim StrBookMarkName As String 'Laufe durch den gesamten Text. Nimm das was du gebrauchen kannst und ersetze den Rest. StrBookMarkName = "" For i = 1 To Len( StrText ) Select Case LCase(Mid( StrText, i, 1 )) Case " ","|","/","<",">" StrBookMarkName = StrBookMarkName & "_" Case "ä" StrBookMarkName = StrBookMarkName & "ae" Case "ö" StrBookMarkName = StrBookMarkName & "oe" Case "ü" StrBookMarkName = StrBookMarkName & "ue" Case Else StrBookMarkName = StrBookMarkName & Mid(StrText, i, 1 ) End Select Next i 'Nun prüfe, ob es diese Textmarke schon gibt und hänge ggf. eine Zufallszahl an. Randomize() MakeHTMLAnchorsBookmark = StrBookMarkName Do While MakeHTMLAnchorsFoundBookmark(MakeHTMLAnchorsBookmark) 'Calculate a bookmark name with the random number generator MakeHTMLAnchorsBookmark = StrBookMarkName & _ Right("00000" & Fix(1000000 * Rnd()),6) Loop End Function Function MakeHTMLAnchorsFoundBookmark(StrBookmark As String) As Boolean 'Prüfe ob es eine gegebene Textmarke schon gibt Dim i As Integer MakeHTMLAnchorsFoundBookmark = False 'Laufe dazu alle Textmarken durch und Vergleiche For i = 0 To Selection.Bookmarkcount - 1 If StrBookmark = oActiveWindow.BookmarkName(i) Then MakeHTMLAnchorsFoundBookmark = True Endif Next i End Function