[SOLVED:] Using VBA to put in HTML tags for bolded, italicized or underlined text

1 Attachment(s)

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

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 want it to appear as follows:
Capital structure

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:

Code:

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 = "^&" .Font.Bold = False .Font.Italic = False End With .Execute Replace:=wdReplaceAll .ClearFormatting .Font.Bold = True With .Replacement .ClearFormatting .Text = "^&" .Font.Bold = False End With .Execute Replace:=wdReplaceAll .ClearFormatting .Font.Italic = True With .Replacement .ClearFormatting .Text = "^&" .Font.Italic = False End With .Execute Replace:=wdReplaceAll .ClearFormatting .Font.Underline = True With .Replacement .ClearFormatting .Text = "^&" .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

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

Code:

Const ItalicsStart as String = "" Const ItalicsEnd as String = "" Const StartB as String = "" Const BEnd As String = "" 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.

Code:

.Text = "^&"

I think it should be used as

Code:

.Text = "" ^& "" 'OR .Text = StartB_I ^& EndB_I

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

Code:

.Text = "" & .Replacement & ""

Something like this perhaps:

Code:

Sub TagAndClearFormating() Dim oRng As Word.Range Dim arrTagPairs() As String, arrTags() As String Dim lngIndex As Long arrTagPairs = Split("*|*|*|*", "|") 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

Something like this perhaps:

Code:

Sub TagAndClearFormating() Dim oRng As Word.Range Dim arrTagPairs() As String, arrTags() As String Dim lngIndex As Long arrTagPairs = Split("*|*|*|*", "|") 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("*|*|*|*", "|") 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

Quote:

Originally Posted by gmaxey

Something like this perhaps:

Code:

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("*|*|*|*", "|") 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.

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!

Thank you. Glad to help.