Suchen und Hinzufügen von unterstrichenen Wörtern in VBA Word

Question

Ich habe gesucht, ob es möglich ist, ein Makro zu erstellen, das unterstrichene Wörter in einem Word-Dokument findet und sie in die HTML-Tags konvertiert. Ich habe versucht, ein Makro aufzunehmen, um das zu tun, aber es fügt nur Tags zu allen Wörtern hinzu. Ich stelle auch einen Teil des Codes habe ich versucht, zu verwenden:

Dim myWords()  As String 
Dim i    As Long 
Dim myDoc   As Document: Set myDoc = ActiveDocument ' Change as needed 
Dim aRange   As Range: Set aRange = myDoc.Content 
Dim sRanges   As StoryRanges: Set sRanges = myDoc.StoryRanges 
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array 
Dim Sentence  As Range 
Dim w    As Variant 

Application.ScreenUpdating = False 
ReDim myWords(aRange.Words.Count) ' set a array as large as the 
            ' number of words in the doc 

For Each Sentence In myDoc.StoryRanges 
    For Each w In Sentence.Words 
     If w.Font.Underline <> wdUnderlineNone Then 
      myDoc.Sentence.Range.InsertBefore "<u>" 
      myDoc.Sentence.Range.InsertAfter "</u>" 
     End If 

Answer 1

Gut, das Code sieht familiar!

Hier ist eine kleine Änderung, was Sie getan haben, die das Tag um jedes unterstrichene Wort hinzufügen sollte. Beachten Sie, dass Sie die Unterstreichungseigenschaft entfernen und das Tag anschließend hinzufügen müssen. Andernfalls behandelt Word das neu eingeführte Tag als neues Wort und wiederholt den Vorgang.

Sub ChangeUnderLineToHTML() 
    Dim myDoc   As Document: Set myDoc = ActiveDocument ' Change as needed 
    Dim aRange   As Range: Set aRange = myDoc.Content ' Change as needed 
    Dim sRanges   As Variant: Set sRanges = myDoc.StoryRanges 
    Dim sentence  As Object 
    Dim w    As Object 

    For Each sentence In sRanges 
     For Each w In sentence.Words 
      If w.Font.Underline <> wdUnderlineNone Then 
       w.Font.Underline = wdUnderlineNone 
       w.Text = "<u>" & w.Text & "</u>" 
      End If 
     Next w 
    Next sentence 

    'Clean Up 
    Set myDoc = Nothing 
    Set aRange = Nothing 
    Set sRanges = Nothing 
    Set w = Nothing 
    Set sentence = Nothing 
End Sub