Using VBA to put in HTML tags for bolded, italicized or underlined text

[Pat Parker]

Hi all. I am a novice at VBA who learns by looking at existing VBA code and making small changes to it until I figure out what I need to do. However, I am at an impasse here. I have a problem where I am trying to use VBA code I found online to go through a word doc and put HTML type tags for anything that is bold, underlined, or italic. The problem is that the code has a problem with the outline format of my word doc (see attached with the macro A_Add_HTML_tags contained in it). For example, if you run the macro, the outline section (iii) appears as follows:

Capital structure<i><b>

I want it to appear as follows:
<b><i>Capital structure<i><b>

The other tags that I need are at the end of the preceding line, which doesn't help me. I tried changing .MatchWholeWord to True which somewhat accomplishes what I need, but then every single word has tags. Any advice would be greatly appreciated. VBA code is pasted below:

Sub A_Add_HTML_tags()  ' 1102/16 - should add HTML tags to all word docs in the folder
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
' strFolder = GetFolder
' strFolder = "C:\" ' I added this to override the above line
' If strFolder = "" Then Exit Sub
 'strFile = Dir(strFolder & "\*.doc", vbNormal)
' While strFile <> ""
'  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With ActiveDocument.Range.Find
    .Text = ""
    .Forward = True
'    .Wrap = wdFindStop ' this is from the bold tag macro
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = True
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    
    .ClearFormatting
    .Font.Bold = True
    .Font.Italic = True
    With .Replacement
      .ClearFormatting
      .Text = "<b><i>^&<i></b>"
      .Font.Bold = False
      .Font.Italic = False
    End With
    .Execute Replace:=wdReplaceAll
    
    
    
    .ClearFormatting
    .Font.Bold = True
    With .Replacement
      .ClearFormatting
      .Text = "<b>^&</b>"
      .Font.Bold = False
    End With
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Font.Italic = True
    With .Replacement
      .ClearFormatting
      .Text = "<i>^&<i>"
      .Font.Italic = False
    End With
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Font.Underline = True
    With .Replacement
      .ClearFormatting
      .Text = "<u>^&<u>"
      .Font.Underline = False
    End With
    .Execute Replace:=wdReplaceAll
  End With
'  wdDoc.Close SaveChanges:=True
'  strFile = Dir()
' Wend
' Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

[SamT]

I don't code for Word, but this post will bump your thread back to the top.

If I did, I would start by defining Constants for the various tags

Const ItalicsStart as String = "<i>"
Const ItalicsEnd as String = "</i>"
Const StartB as String = "<b>"
Const BEnd As String = "</b>"
Const StartB_I As String = StartB & ItalicsStart

Is this line is supposed to replace some string or another with the "^&"? That just doesn't look right to me, but it is what you have.

.Text = "<b><i>^&<i></b>"

I think it should be used as

.Text = "<b><i>" ^& "<i></b>"
'OR
.Text = StartB_I ^& EndB_I

Being as I don't know Word, Just what I see you using, try this

.Text = "<b><i>" & .Replacement & "<i></b>"

[gmaxey]

Something like this perhaps:

Sub TagAndClearFormating()
Dim oRng As Word.Range
Dim arrTagPairs() As String, arrTags() As String
Dim lngIndex As Long
  arrTagPairs = Split("<i><b>*</i></b>|<i>*</i>|<b>*</b>|<u>*</u>", "|")
  For lngIndex = 0 To UBound(arrTagPairs)
    arrTags = Split(arrTagPairs(lngIndex), "*")
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      If InStr(arrTags(0), "b") > 0 Then .Font.Bold = True
      If InStr(arrTags(0), "i") > 0 Then .Font.Italic = True
      If InStr(arrTags(0), "u") > 0 Then .Font.Underline = True
      While .Execute
        With oRng
          If InStr(arrTags(0), "b") > 0 Then .Font.Bold = False
          If InStr(arrTags(0), "i") > 0 Then .Font.Italic = False
          If InStr(arrTags(0), "u") > 0 Then .Font.Underline = False
          If .Characters.Last = vbCr Then .End = .End - 1
          .Text = arrTags(0) & .Text & arrTags(1)
          .Collapse wdCollapseEnd
        End With
      Wend
    End With
  Next lngIndex
End Sub

[gmaxey]

Something like this perhaps:

Sub TagAndClearFormating()
Dim oRng As Word.Range
Dim arrTagPairs() As String, arrTags() As String
Dim lngIndex As Long
  arrTagPairs = Split("<i><b>*</i></b>|<i>*</i>|<b>*</b>|<u>*</u>", "|")
  For lngIndex = 0 To UBound(arrTagPairs)
    arrTags = Split(arrTagPairs(lngIndex), "*")
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      If InStr(arrTags(0), "b") > 0 Then .Font.Bold = True
      If InStr(arrTags(0), "i") > 0 Then .Font.Italic = True
      If InStr(arrTags(0), "u") > 0 Then .Font.Underline = True
      While .Execute
        With oRng
          If InStr(arrTags(0), "b") > 0 Then .Font.Bold = False
          If InStr(arrTags(0), "i") > 0 Then .Font.Italic = False
          If InStr(arrTags(0), "u") > 0 Then .Font.Underline = False
          If .Characters.Last = vbCr Then .End = .End - 1
          .Text = arrTags(0) & .Text & arrTags(1)
          .Collapse wdCollapseEnd
        End With
      Wend
    End With
  Next lngIndex
Sub TagAndClearFormating()
Dim oRng As Word.Range
Dim arrTagPairs() As String, arrTags() As String
Dim arrChars() As String, arrEntities() As String
Dim lngIndex As Long
  arrTagPairs = Split("<i><b>*</i></b>|<i>*</i>|<b>*</b>|<u>*</u>", "|")
  For lngIndex = 0 To UBound(arrTagPairs)
    arrTags = Split(arrTagPairs(lngIndex), "*")
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      If InStr(arrTags(0), "b") > 0 Then .Font.Bold = True
      If InStr(arrTags(0), "i") > 0 Then .Font.Italic = True
      If InStr(arrTags(0), "u") > 0 Then .Font.Underline = True
      While .Execute
        With oRng
          If InStr(arrTags(0), "b") > 0 Then .Font.Bold = False
          If InStr(arrTags(0), "i") > 0 Then .Font.Italic = False
          If InStr(arrTags(0), "u") > 0 Then .Font.Underline = False
          If .Characters.Last = vbCr Then .End = .End - 1
          .Text = arrTags(0) & .Text & arrTags(1)
          .Collapse wdCollapseEnd
        End With
      Wend
    End With
  Next lngIndex
  arrChars = Split("38|34|39|145|146|147|148|162", "|")
  arrEntities = Split("&|"|'|'|'|&|&|¢", "|")
  For lngIndex = 0 To UBound(arrChars)
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      .Text = Chr(arrChars(lngIndex))
      .Replacement.Text = arrEntities(lngIndex)
      .Execute Replace:=wdReplaceAll
    End With
  Next lngIndex
End Sub


End Sub

[Pat Parker]

Something like this perhaps:

Sub TagAndClearFormating()
Dim oRng As Word.Range
Dim arrTagPairs() As String, arrTags() As String
Dim arrChars() As String, arrEntities() As String
Dim lngIndex As Long
  arrTagPairs = Split("<i><b>*</i></b>|<i>*</i>|<b>*</b>|<u>*</u>", "|")
  For lngIndex = 0 To UBound(arrTagPairs)
    arrTags = Split(arrTagPairs(lngIndex), "*")
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      If InStr(arrTags(0), "b") > 0 Then .Font.Bold = True
      If InStr(arrTags(0), "i") > 0 Then .Font.Italic = True
      If InStr(arrTags(0), "u") > 0 Then .Font.Underline = True
      While .Execute
        With oRng
          If InStr(arrTags(0), "b") > 0 Then .Font.Bold = False
          If InStr(arrTags(0), "i") > 0 Then .Font.Italic = False
          If InStr(arrTags(0), "u") > 0 Then .Font.Underline = False
          If .Characters.Last = vbCr Then .End = .End - 1
          .Text = arrTags(0) & .Text & arrTags(1)
          .Collapse wdCollapseEnd
        End With
      Wend
    End With
  Next lngIndex
  arrChars = Split("38|34|39|145|146|147|148|162", "|")
  arrEntities = Split("&|"|'|'|'|&|&|¢", "|")
  For lngIndex = 0 To UBound(arrChars)
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      .Text = Chr(arrChars(lngIndex))
      .Replacement.Text = arrEntities(lngIndex)
      .Execute Replace:=wdReplaceAll
    End With
  Next lngIndex
End Sub

Greg - I can't thank you enough for doing this. You did a lot more than just point out my problems - you wrote the code to accomplish the task. This macro works fantastically and is exactly what I needed. I just checked out your personal site and see you are a Navy vet - my father-in-law is also a Navy vet and I have 2 nephews presently serving in the Navy (chocks and locks). I made a small donation through your site and I truly appreciate you doing this for me. You are a good egg.

[Pat Parker]

Sam, thank you for taking the time to answer. I tried your suggestions but kept receiving syntax errors. However, Greg's solution works splendidly. Thanks again for helping me out!

[gmaxey]

Thank you. Glad to help.