Option Explicit
Sub FettenTextInHtmlTags_b_Wandeln()
' im gesamten Text des aktiven Documents wird
' fetter Text in Tags <b>...</b> eingefaßt und
' der fette Text in normalen Text gewandelt.
Const c_TAG_ANFANG = <b>
Const c_TAG_ENDE = </b>
Dim doc As Document
Dim l_Start_anf As Long, l_Start_end As Long
Dim l_PosEnd As Long, l_pos As Long
Set doc = ActiveDocument
->Suchbereichsende setzen
l_PosEnd = doc.Content.End
Do
->Formatierung Fett suchen, vom Ende rückwärts
Selection.Start = doc.Content.Start
Selection.End = l_PosEnd
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = False
.Wrap = wdFindStop
.Text = ^?
.MatchWholeWord = False
.MatchWildcards = False
.MatchCase = False
.Font.Bold = True
If .Execute() = False Then Exit Do->nichts gefunden ?
End With
->Position merken
l_Start_anf = Selection.Start
l_Start_end = Selection.End
->Zeichen davor auch unterstrichen ?
l_pos = l_Start_anf - 1
Do
If l_pos < 0 Then Exit Do
If doc.Range(Start:=l_pos, End:=l_pos + 1).Font.Bold _
= False Then Exit Do
->Start-Position erweitern
l_Start_anf = l_pos
l_pos = l_pos - 1
Loop
->fetter Bereich
With doc.Range(Start:=l_Start_anf, End:=l_Start_end)
->fette Formatierung entfernen
.Font.Bold = False
->Ende-Tag einfügen
.InsertAfter c_TAG_ENDE
doc.Range(Start:=l_Start_end, _
End:=l_Start_end + Len(c_TAG_ENDE)).Font.Underline _
= wdUnderlineNone
->Anfangs-Tag einfügen
.InsertBefore c_TAG_ANFANG
doc.Range(Start:=l_Start_anf, _
End:=l_Start_anf + Len(c_TAG_ANFANG)).Font.Underline _
= wdUnderlineNone
End With
->Suchbereichsende vor letztes Anfangs-Tag setzen
l_PosEnd = l_Start_anf - 1 - Len(c_TAG_ANFANG)
Loop While l_PosEnd > 0
Set doc = Nothing
End Sub
