Makro in Word zum Suchen und Ersetzten?

  • #1
D

Dani83

Guest
Hallo Zusammen,

habe folgendes Problem: Brauche ein Makro das mir in einem Text in dem HTML-Codes vorkommen, diese raussucht und Ersetzt!

Beispiel: blablablablabla <u>Hallo</u>

Ergebnis: blablablablabla Hallo

Das Problem ist das es absolut variabel sein muss!


Danke für Eure Hilfe!!!!
 
  • #3
Hi Dani83,

also möchtest einen Makro für Word.

- gesamten Text durchsuchen nach <u>irgendwas</u>
- gefundene Stellen ersetzen durch unterstrichenes irgendwas
- dabei ggf. überflüssige Leerstellen entfernen

So richtig ?

Gruß Matjes :)
 
  • #4
Das könnte dann so aussehen:
Code: 
Sub HtmlTagsDurchUnterstrichenenTextErsetzen()

  Const c_TAG_ANFANG = <u>
  Const c_TAG_ENDE = </u>
  
  Dim doc As Document, s_Text As String, l_PosAnf As Long
  Dim l_TagStart_anf As Long, l_TagStart_end As Long
  Dim l_TagStop_anf As Long, l_TagStop_end As Long, s_tmp As String
  
  
  Set doc = ActiveDocument
  
  l_PosAnf = 0
  
  Do
   ->Start-Tag suchen
    Selection.Start = l_PosAnf
    Selection.End = doc.Content.End
    With Selection.Find
      .ClearFormatting
      .MatchWholeWord = False
      .MatchCase = False
      .Wrap = wdFindStop
     ->nichts mehr gefunden ?
      If .Execute(FindText:=c_TAG_ANFANG) = False Then Exit Do
    End With
    
   ->Position merken
    l_TagStart_anf = Selection.Start
    l_TagStart_end = Selection.End
    
   ->Stop-Tag suchen
    Selection.Start = l_TagStart_end
    Selection.End = doc.Content.End
    With Selection.Find
      .ClearFormatting
      .Forward = True
      .MatchWholeWord = False
      .MatchCase = False
      .Wrap = wdFindStop
     ->nichts mehr gefunden ?
      If .Execute(FindText:=c_TAG_ENDE) = False Then
        doc.Range(l_TagStart_anf, l_TagStart_end).Select
        MsgBox (Hier fehlt das STOP-Tag.)
        Exit Do
      End If
    End With
        
   ->Position merken
    l_TagStop_anf = Selection.Start
    l_TagStop_end = Selection.End
    
   ->Fundstelle bearbeiten
    
   ->Stop-Tag gegen  ersetzen
    doc.Range(Start:=l_TagStop_anf, _
              End:=l_TagStop_end).Text = 
    
   ->Tag-Text bearbeiten
    s_Text = doc.Range(Start:=l_TagStart_end, _
                         End:=l_TagStop_anf).Text
   ->Leerzeichen an Anfang  und Ende entfernen
    s_Text = Trim(s_Text)
    doc.Range(Start:=l_TagStart_end, _
                End:=l_TagStop_anf).Text = s_Text
   ->unterstreichen
    doc.Range(Start:=l_TagStart_end, _
                End:=l_TagStart_end + Len(s_Text)).Underline = True
                                
   ->Start-Tag gegen  ersetzen
    doc.Range(Start:=l_TagStart_anf, _
              End:=l_TagStart_end).Text = 
    
   ->Selectionsanfang auf letzte Fundstelle
    l_PosAnf = l_TagStart_anf + 1

  Loop
  Set doc = Nothing

End Sub

Gruß Matjes :)
 
  • #5
Danke schön!!!

Werd das Makro jetzt direkt mal testen!
 
  • #6
Makro klappt super! Danke schön!

Nächstes Problem:

Jetzt brauch ich ein Makro, das genau andersrum läuft...
...also von Formatierung nach HTML-Code!

Danke jetzt schonmal für eure Hilfe!
 
  • #7
Hi Dani83,

Das ist leichter gesagt als getan. Woran soll der Makro denn erkennen, welchen Text er in <u> </u> setzen soll ?

Gruß Matjes :)
 
  • #8
Also das Makro soll so funktionieren: es soll einen beliebigen Text auf abweichende Formatierung durchsuchen. Fettgedrucktes soll dann in <b>...</b> stehen, Unterschrichenes in <u>...</u> und dann eben unformatiert (Format wie der restliche Text)!

Wäre super wenn ihr mir helfen könntet...!!!
Denn ich bin total :-\
 
  • #9
Hallo Dani83,

ich hab dir jetzt ein Pärchen geschrieben:
HtmlTags_u_InUnterstrichen_HtmlTags_b_InFett
UnterstrichenInHtmlTags_u_FettInHtmlTags_b

Pack den unten angegebenen Code in ein Modul.

Der alte Makro ist darin enthalten, aber etwas modifiziert.

Gruß Matjes :)
Code: 
Sub HtmlTags_u_InUnterstrichen_HtmlTags_b_InFett()
  Application.ScreenUpdating = False
  Call HtmlTags_u_DurchUnterstrichenenTextErsetzen
  Call HtmlTags_b_DurchFettenTextErsetzen
  Selection.Collapse
  Application.ScreenUpdating = True
End Sub
Sub UnterstrichenInHtmlTags_u_FettInHtmlTags_b()
  Application.ScreenUpdating = False
  Call UnterstrichenenTextInHtmlTags_u_Wandeln
  Call FettenTextInHtmlTags_b_Wandeln
  Selection.Collapse
  Application.ScreenUpdating = True
End Sub
Private Function HtmlTags_b_DurchFettenTextErsetzen()

  Const c_TAG_ANFANG = <b>
  Const c_TAG_ENDE = </b>
  
  Dim doc As Document, s_Text As String, l_PosAnf As Long
  Dim l_TagStart_anf As Long, l_TagStart_end As Long
  Dim l_TagStop_anf As Long, l_TagStop_end As Long, s_tmp As String
  Dim l_Bold_Anf As Long, l_Bold_End As Long, x As Long
  
  Set doc = ActiveDocument
  
  l_PosAnf = 0
  
  Do
   ->Start-Tag suchen
    Selection.Start = l_PosAnf
    Selection.End = doc.Content.End
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .Text = c_TAG_ANFANG
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchCase = False
      If .Execute() = False Then Exit Do->nichts mehr gefunden ?
    End With
    
   ->Position merken
    l_TagStart_anf = Selection.Start
    l_TagStart_end = Selection.End
    
   ->Stop-Tag suchen
    Selection.Start = l_TagStart_end
    Selection.End = doc.Content.End
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .Text = c_TAG_ENDE
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchCase = False
      If .Execute() = False Then->nichts mehr gefunden ?
        doc.Range(l_TagStart_anf, l_TagStart_end).Select
        MsgBox (Hier fehlt das STOP-Tag.)
        Exit Do
      End If
    End With
        
   ->Position merken
    l_TagStop_anf = Selection.Start
    l_TagStop_end = Selection.End
    
   ->Fundstelle bearbeiten
    
   ->Stop-Tag gegen  ersetzen
    doc.Range(Start:=l_TagStop_anf, _
              End:=l_TagStop_end).Text = 
    
   ->Leerzeichen am Anfang nicht fett
    l_Bold_Anf = l_TagStart_end
    For x = l_TagStart_end To l_TagStop_anf
      l_Bold_Anf = x
      If doc.Range(x, x + 1).Text <>   Then: Exit For
    Next
    
   ->Leerzeichen am Ende nicht fett
    l_Bold_End = l_TagStop_anf
    For x = l_TagStop_anf To l_Bold_Anf Step -1
      l_Bold_End = x
      If doc.Range(x - 1, x).Text <>   Then Exit For
    Next
    
   ->fett setzen
    If l_Bold_Anf < l_Bold_End Then
      doc.Range(Start:=l_Bold_Anf, _
                  End:=l_Bold_End).Bold = True
    End If
    
   ->Start-Tag gegen  ersetzen
    doc.Range(Start:=l_TagStart_anf, _
              End:=l_TagStart_end).Text = 
    
   ->Selectionsanfang auf letzte Fundstelle
    l_PosAnf = l_TagStart_anf + 1

  Loop
  Set doc = Nothing

End Function
Private Function HtmlTags_u_DurchUnterstrichenenTextErsetzen()

  Const c_TAG_ANFANG = <u>
  Const c_TAG_ENDE = </u>
  
  Dim doc As Document, s_Text As String, l_PosAnf As Long
  Dim l_TagStart_anf As Long, l_TagStart_end As Long
  Dim l_TagStop_anf As Long, l_TagStop_end As Long, s_tmp As String
  Dim l_Underline_Anf As Long, l_Underline_End As Long, x As Long
  
  Set doc = ActiveDocument
  
  l_PosAnf = 0
  
  Do
   ->Start-Tag suchen
    Selection.Start = l_PosAnf
    Selection.End = doc.Content.End
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .Text = c_TAG_ANFANG
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchCase = False
      If .Execute() = False Then Exit Do->nichts mehr gefunden ?
    End With
    
   ->Position merken
    l_TagStart_anf = Selection.Start
    l_TagStart_end = Selection.End
    
   ->Stop-Tag suchen
    Selection.Start = l_TagStart_end
    Selection.End = doc.Content.End
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .Text = c_TAG_ENDE
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchCase = False
      If .Execute() = False Then->nichts mehr gefunden ?
        doc.Range(l_TagStart_anf, l_TagStart_end).Select
        MsgBox (Hier fehlt das STOP-Tag.)
        Exit Do
      End If
    End With
        
   ->Position merken
    l_TagStop_anf = Selection.Start
    l_TagStop_end = Selection.End
    
   ->Fundstelle bearbeiten
    
   ->Stop-Tag gegen  ersetzen
    doc.Range(Start:=l_TagStop_anf, _
              End:=l_TagStop_end).Text = 
    
   ->Leerzeichen am Anfang nicht mitunterstreichen
    l_Underline_Anf = l_TagStart_end
    For x = l_TagStart_end To l_TagStop_anf
      l_Underline_Anf = x
      If doc.Range(x, x + 1).Text <>   Then: Exit For
    Next
    
   ->Leerzeichen am Ende nicht mitunterstreichen
    l_Underline_End = l_TagStop_anf
    For x = l_TagStop_anf To l_Underline_Anf Step -1
      l_Underline_End = x
      If doc.Range(x - 1, x).Text <>   Then Exit For
    Next
    
   ->unterstreichen
    If l_Underline_Anf < l_Underline_End Then
      doc.Range(Start:=l_Underline_Anf, _
                  End:=l_Underline_End).Underline = True
    End If
    
   ->Start-Tag gegen  ersetzen
    doc.Range(Start:=l_TagStart_anf, _
              End:=l_TagStart_end).Text = 
    
   ->Selectionsanfang auf letzte Fundstelle
    l_PosAnf = l_TagStart_anf + 1

  Loop
  Set doc = Nothing

End Function
Private Function 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 Function
'***************************************************
Private Function UnterstrichenenTextInHtmlTags_u_Wandeln()
' im gesamten Text des aktiven Documents werden
' Unterstreichungen (wdUnderlineSingle) in
' Tags <u>...</u> eingefaßt und die Unterstreichung
' entfernt.

  Const c_TAG_ANFANG = <u>
  Const c_TAG_ENDE = </u>
  
  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
   ->Unterstreichung 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.Underline = wdUnderlineSingle
      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.Underline <> _
        wdUnderlineSingle Then Exit Do
     ->Start-Position erweitern
      l_Start_anf = l_pos
      l_pos = l_pos - 1
    Loop
    
   ->unterstrichener Bereich
    With doc.Range(Start:=l_Start_anf, End:=l_Start_end)
     ->Unterstreichung entfernen
      .Font.Underline = wdUnderlineNone
     ->Ende-Tag einfügen
      .InsertAfter c_TAG_ENDE
      doc.Range(Start:=l_Start_end, _
                End:=l_Start_end + Len(c_TAG_ENDE)).Font.Bold = False
     ->Ende-Tag einfügen
      .InsertBefore c_TAG_ANFANG
      doc.Range(Start:=l_Start_anf, _
                End:=l_Start_anf + Len(c_TAG_ANFANG)).Font.Bold = False

    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 Function
 
  • #10
Super DANKE!!!
 
  • #11
Makro funktioniert super....hab jetzt nur noch ein kleines Problem...
Private Function UnterstrichenenTextInHtmlTags_u_Wandeln ändert auch im Text vorhandene Hyperlinks (sind ja auch unterstrichen), das darf aber nicht passieren!

Mal wieder ein dickes Danke im voraus für die liebe Hilfe!
 
  • #12
Nun läßt die Funktion die Finger von Hyperlinks  ;D Mal schauen, was noch kommt  ::)

Gruß Matjes  :)

Code: 
'***************************************************
Private Function UnterstrichenenTextInHtmlTags_u_Wandeln()
' im gesamten Text des aktiven Documents werden
' Unterstreichungen (wdUnderlineSingle) in
' Tags <u>...</u> eingefaßt und die Unterstreichung
' entfernt.

  Const c_TAG_ANFANG = <u>
  Const c_TAG_ENDE = </u>
  
  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
   ->Unterstreichung 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.Underline = wdUnderlineSingle
      If .Execute() = False Then Exit Do->nichts gefunden ?
    End With
    
   ->Position merken
    l_Start_anf = Selection.Start
    l_Start_end = Selection.End
    
   ->Prüfen, ob Hyperlink
    
    If Selection.Hyperlinks.Count = 0 Then
        
     ->Zeichen davor auch unterstrichen ?
      l_pos = l_Start_anf - 1
      Do
        If l_pos < 0 Then Exit Do
       ->Prüfen, unterstrichen
        If doc.Range(Start:=l_pos, End:=l_pos + 1).Font.Underline <> _
          wdUnderlineSingle Then Exit Do
       ->Prüfen, Hyperlink
        If doc.Range(Start:=l_pos, End:=l_pos + 1).Hyperlinks.Count <> _
          0 Then Exit Do
       ->Start-Position erweitern
        l_Start_anf = l_pos
        l_pos = l_pos - 1
      Loop
      
     ->unterstrichener Bereich
      With doc.Range(Start:=l_Start_anf, End:=l_Start_end)
       ->Unterstreichung entfernen
        .Font.Underline = wdUnderlineNone
       ->Ende-Tag einfügen
        .InsertAfter c_TAG_ENDE
        doc.Range(Start:=l_Start_end, _
                  End:=l_Start_end + Len(c_TAG_ENDE)).Font.Bold = False
       ->Ende-Tag einfügen
        .InsertBefore c_TAG_ANFANG
        doc.Range(Start:=l_Start_anf, _
                  End:=l_Start_anf + Len(c_TAG_ANFANG)).Font.Bold = False
  
      End With
      
     ->Suchbereichsende vor letztes Anfangs-Tag setzen
      l_PosEnd = l_Start_anf - 1 - Len(c_TAG_ANFANG)
    Else
     ->Fundstelle war Hyperlink
     ->Suchbereichsende vor letzten Fundort setzen
      Selection.Hyperlinks(1).Range.Select
      l_PosEnd = Selection.Start
    End If
  Loop While l_PosEnd > 0
  Set doc = Nothing

End Function
 
  • #13
Danke! Du bist echt klasse!

Mir fällt bestimmt noch was ein.... ;D
 
  • #14
Hallo Matjes,
bräuchte doch noch mal Deine Hilfe!
Dachte eigentlich das ich das Makro selbst noch erweitert bekomme, war aber wohl nix... :-[

Eigentlich soll das Makro jegliche Formatierung die vom Standard abweicht erkennen und in HTML-Tags umwandeln.

Also, zusätzlich zu Fett und Unterschrichen, auch Kursiv, andere Farbe, andere Größe, Links, eMail-Adressen, das & Zeichen und natürlich auch Kombinationen aus all dem!

Wäre suuuuuper von Dir wenn Du mir da nochmal helfen kannst!!!!!
Gerne auch mit Erklärung....möchte das ja lernen...!  :)
 
Thema:

Makro in Word zum Suchen und Ersetzten?

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.838
Beiträge
707.961
Mitglieder
51.491
Neuestes Mitglied
haraldmuc
Oben