CODEWITHSUNDEEP
vbams-word
Absolut Watkins
Absolut Watkins

Reputation: 1

Finding and adding to Underlined Words in VBA Word

I was looking to see if it was possible to create a macro that locates underlined words in a word document and converts them to the html tags. i tried to record a macro to do that but it just adds tags to all words. I also provide some of the code i tried to use:

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

Upvotes: 0

Views: 1398

Answers (1)

Ryan Wildry
Ryan Wildry

Reputation: 5677

Well this code looks familiar!

Here's a tweak on what you've done that should add the tag around each underlined word. It's important to note, you must remove the underline property, and then add the tag. Otherwise word will treat the newly introduced tag as a new word, and repeat the process.

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

Upvotes: 2

Related Questions