3

Microsoft Word affords the ability to search for formatted text and to replace it and the formatting. This feature is great in my line of work, where I have to convert Word documents into online surveys. A simple example would be to find a bold word and replace it with <strong>bold</strong>.

However, there are cases where the document we receive has extraneous, unformatted, white-space in between said formatting. This makes the process of finding and replacing all bold text a bit trickier. Also, there are cases where white-space has formatting applied when it shouldn't.

What is a macro, or wildcard (regex) search/replace, to find and replace all white-space with incorrect formatting with the correctly formatted white-space?

Two criteria for "incorrectly" is that the last white-space on the line must be unformatted, and white-space in between two formatted words must be formatted. Essentially, I'm trying to create the cleanest Replace All possible.

Take the following screenshot as an example:

screenshot

The pink/purple highlights represent white-space that is normal style, but should be italicized.

The red/orange highlight represents white-space that is bolded, but should be normal, un-bolded style.

In both cases, I would need the macro, or wildcard find/replace, to know to convert one to italic, and remove the bolding style altogether from the other.

To further expound:

Currently, if I do a find and replace all by only leveraging Microsoft Word's font style format, it results in three <em> elements in some lines, e.g.:

<em>The average American expects the rate of deflation (opposite</em> <em>of</em> <em>inflation)</em> will be between 0% and 2%

The ideal result would be one <em> element:

<em>The average American expects the rate of deflation (opposite of inflation)</em> will be between 0% and 2%

(Note that I use italic and bold as examples, but the same could be said for underline text as well.)

  • It it is white space how can you tell if it italicised or not? This is not clear from your screenshot. – DavidPostill Apr 23 '18 at 18:45
  • @DavidPostill I've updated the image with highlighted areas and further expounded upon my intended goal. – Alexander Dixon Apr 23 '18 at 19:04
  • How about making a second step and replacing "</em> <em>" (the same for other elements) with " "? – endrju Apr 23 '18 at 22:13
  • @endrju That would certainly work. What I do now is simply add the appropriate styling before I perform the find and replace style. The process is manual, as is your suggestion. I'm looking for something a bit more autonomous that perhaps leverages some simple but powerful regular expressions. – Alexander Dixon Apr 25 '18 at 14:15
2
+100

Word's "wildcard" find and replace uses a (very) limited, non-standard form of regular expressions. Coupled with the fact that you want to find and replace formats as well, means that it is not possible to do what you require purely using the built-in find and replace, wildcards or not.

However, it is possible to leverage Word's find/replace in a macro to accomplish intelligent white-space conversion. It is also possible to write a macro using only the proper regex available to VBA, without accessing Word's find/replace.

The following solution does the former and uses the Find object to programmatically perform Word's find/replace without using wildcards. It does however use VBA's (or more strictly VBScript's) regexes in a couple of helper functions to make them simpler.

Instead of just converting the white-space appropriately, which would then still require further find and replace all steps, the script effectively converts the white-space and does the HTML wrapping and format removal all at the same time.

'============================================================================================
' Module     : <in any standard module>
' Version    : 0.1.4
' Part       : 1 of 1
' References : Microsoft VBScript Regular Expressions 5.5   [VBScript_RegExp_55]
' Source     : https://superuser.com/a/1321448/763880
'============================================================================================
Option Explicit

Private Const s_BoldReplacement = "<strong>^&</strong>"
Private Const s_ItalicReplacement = "<em>^&</em>"
Private Const s_UnderlineReplacement = "<u>^&</u>"

Private Enum FormatType
  Bold
  Italic
  Underline
End Enum

Public Sub ConvertFormattedTextToHTML()

  With Application
    .ScreenUpdating = True ' Set to False to speed up execution for large documents
    ConvertTextToHTMLIf Bold
    ConvertTextToHTMLIf Italic
    ConvertTextToHTMLIf Underline
    .ScreenUpdating = True
  End With

End Sub

Private Sub ConvertTextToHTMLIf _
            ( _
                       ByVal peFormatType As FormatType _
            )

  ' Create/setup a Find object
  Dim rngFound As Range: Set rngFound = ActiveDocument.Content
  With rngFound.Find
    .MatchCase = True ' Required, otherwise an all-caps found chunk's replacement is converted to all-caps
    .Format = True
    Select Case peFormatType
      Case FormatType.Bold:
        .Font.Bold = True
        .Replacement.Font.Bold = False
        .Replacement.Text = s_BoldReplacement
      Case FormatType.Italic:
        .Font.Italic = True
        .Replacement.Font.Italic = False
        .Replacement.Text = s_ItalicReplacement
      Case FormatType.Underline:
        .Font.Underline = True
        .Replacement.Font.Underline = False
        .Replacement.Text = s_UnderlineReplacement
    End Select
  End With

  ' Main "chunk" loop:
  ' - Finds the next chunk (contiguous appropriately formatted text);
  ' - Expands it to encompass the following chunks if only separated by unformatted grey-space (white-space + punctuation - vbCr - VbLf)
  ' - Removes (and unformats) leading and trailing formatted grey-space from the expanded-chunk
  ' - Converts the trimmed expanded-chunk to unformatted HTML
  Do While rngFound.Find.Execute() ' (rngFound is updated to the "current" chunk if the find succeeds)
    If rngFound.End = rngFound.Start Then Exit Do ' ## bug-workaround (Bug#2 - see end of sub) ##
    ' Create a duplicate range in order to track the endpoints for the current chunk's expansion
    Dim rngExpanded As Range: Set rngExpanded = rngFound.Duplicate
    rngFound.Collapse wdCollapseEnd ' ## bug-workaround (Bug#2 - see end of sub) ##
    ' Expansion loop
    Do
      ' If more chunks exist ~> the current chunk is fully expanded
      If Not rngFound.Find.Execute() Then Exit Do ' (rngFound is updated to the next chunk if the find succeeds)
      If rngFound.End = rngFound.Start Then Exit Do ' ## bug-workaround (Bug#2 - see end of sub) ##
      ' If the formatting continues across a line boundary ~> terminate the current chunk at the boundary
      If rngFound.Start = rngExpanded.End And rngExpanded.Characters.Last.Text = vbCr Then Exit Do ' ## requiring the vbCr check is a bug-workaround (Bug#1 - see end of sub) ##
      ' If the intervening (unformatted) text doesn't just consist of grey-space ~> the current chunk is fully expanded
      ' (Note that since vbCr & vbLf aren't counted as grey-space, chunks don't expand across line boundaries)
      If NotJustGreySpace(rngFound.Parent.Range(rngExpanded.End, rngFound.Start)) Then Exit Do
      ' Otherwise, expand the current chunk to encompass the inter-chunk (unformatted) grey-space and the next chunk
      rngExpanded.SetRange rngExpanded.Start, rngFound.End
      rngFound.Collapse wdCollapseEnd ' ## bug-workaround (Bug#2 - see end of sub) ##
    Loop
    With rngExpanded.Font
      ' Clear the appropriate format for the expanded-chunk
      Select Case peFormatType
        Case FormatType.Bold:           .Bold = False
        Case FormatType.Italic:       .Italic = False
        Case FormatType.Underline: .Underline = False
      End Select
    End With
    With TrimRange(rngExpanded) ' (rngExpanded also gets updated as a side-effect)
      With .Font
        ' Restore the appropriate format for the trimmed expanded-chunk
        Select Case peFormatType
          Case FormatType.Bold:           .Bold = True
          Case FormatType.Italic:       .Italic = True
          Case FormatType.Underline: .Underline = True
        End Select
        ' (Leading and trailing grey-space is now unformatted wrt the appropriate format)
      End With
      ' Unformat the trimmed expanded-chunk and convert it to HTML
      If .Start = .End _
      Then ' ~~ Grey-space Only ~~
        ' Don't convert. (Has already been unformatted by the previous trim)
      Else ' ~~ Valid Text ~~
        ' Need to copy the trimmed expanded-chunk endpoints back to rngFound as we can't use rngExpanded for the replace
        ' since a duplicate's Find object gets reset upon duplication.
        rngFound.SetRange .Start, .Start ' ## Second .Start instead of .End is a bug-workaround (Bug#2 - see below) ##
        rngFound.Find.Text = rngExpanded.Text ' ## bug-workaround (Bug#2 - see end of sub) ##
        rngFound.Find.Execute Replace:=wdReplaceOne
        rngFound.Find.Text = vbNullString ' ## bug-workaround (Bug#2 - see end of sub) ##
      End If
      rngFound.Collapse wdCollapseStart ' ## bug-workaround (Bug#1 & Bug#2 - see end of sub) ##
    End With
  Loop

  ' ## Bug#1 ## Normally, after a range has been updated as a result of performing the Execute() method to *find*
  ' something, performing a second "find" will continue the search in the rest of the document. If, however, the range
  ' is modified in such a way that the same find would not succeed in the range (as is what typically happens when using
  ' Execute() to perform a find/replace), then a second "find" will *NOT* continue the search in the rest of the
  ' document and fails instead. The solution is to "collapse" the range to zero width. See the following for more info:
  ' http://web.archive.org/web/20180512034406/https://gregmaxey.com/word_tip_pages/words_fickle_vba_find_property.html

  ' ## Bug#2 ## Good ol' buggy Word sometimes decides to split a chunk up even though it doesn't cross a line boundary.
  ' Also, even when the Find object's wrap property is set to wdFindStop (default value), it sometimes behaves as if the
  ' property is set to wdFindContinue, which is also buggy, resulting in Execute() not returning False when no more
  ' chunks exist after wrapping (and *correctly* not updating rngFound). This requires a few work-arounds to cater for
  ' all the resulting combination of edge cases.
  ' See the following for a example doc reproducing this bug:
  ' https://drive.google.com/open?id=11Z9fpxllk2ZHAU90_lTedhYSixQQucZ5
  ' See the following for more details on when this occurs:
  ' https://chat.stackexchange.com/rooms/77370/conversation/word-bug-finding-formats-in-line-before-table

End Sub

' Note that vbCr & vbLf are NOT treated as white-space.
' Also note that "GreySpace" is used to indicate it is not purely white-space, but also includes punctuation.
Private Function IsJustGreySpace _
                 ( _
                            ByVal TheRange As Range _
                 ) _
        As Boolean

  Static rexJustWhiteSpaceExCrLfOrPunctuation As Object '## early binding:- As VBScript_RegExp_55.RegExp
  If rexJustWhiteSpaceExCrLfOrPunctuation Is Nothing Then
    Set rexJustWhiteSpaceExCrLfOrPunctuation = CreateObject("VBScript.RegExp") ' ## early binding:- = New VBScript_RegExp_55.RegExp
    rexJustWhiteSpaceExCrLfOrPunctuation.Pattern = "^(?![^\r\n]*?[\r\n].*$)[\s?!.,:;-]*$" ' ## the last * instead of + is a bug-workaround (Bug#2 - see end of main sub) ##
  End If

  IsJustGreySpace = rexJustWhiteSpaceExCrLfOrPunctuation.test(TheRange.Text)

End Function

Private Function NotJustGreySpace _
                 ( _
                            ByVal TheRange As Range _
                 ) _
        As Boolean

  NotJustGreySpace = Not IsJustGreySpace(TheRange)

End Function

Private Function TrimRange _
                 ( _
                            ByRef TheRange As Range _
                 ) _
        As Range

  Static rexTrim As Object '## early binding:- As VBScript_RegExp_55.RegExp
  If rexTrim Is Nothing Then
    Set rexTrim = CreateObject("VBScript.RegExp") ' ## early binding:- = New VBScript_RegExp_55.RegExp
    rexTrim.Pattern = "(^[\s?!.,:;-]*)(.*?)([\s?!.,:;-]*$)"
  End If

  With rexTrim.Execute(TheRange.Text)(0)
    If Len(.SubMatches(1)) = 0 _
    Then ' ~~ Grey-space Only ~~
      TheRange.Collapse wdCollapseEnd
    Else
      TheRange.SetRange TheRange.Start + Len(.SubMatches(0)), TheRange.End - Len(.SubMatches(2))
    End If
  End With
  Set TrimRange = TheRange

End Function

Criteria:

I have taken the liberty of expanding/extrapolating the criteria for white-space conversion a bit. These can be modified if they don't meet your exact requirements. Currently they are:

  1. Conversion is done for each individual format type independently, i.e. bold, italic, underline. Currently the script processes these three types only. Types can easily be added/removed.
  2. Conversion is done on a per line basis. Line boundaries are never crossed. This is a result of treating the carriage return and linefeed characters as non white-space, and leveraging Word's builtin find terminating a search at a line boundary.
  3. Following on from the request in the comments, the punctuation characters ?!.,:;- are now treated the same as white-space.
  4. Any sequence of consecutive white-space/punctuation, where the non white-space/punctuation character preceding the sequence has the same formatting as the character following the sequence, is converted to that format. Note that this results in the removal of formatting from white-space/punctuation in between unformatted words, as well as "expanding" formatted text to encompass unformatted white-space/punctuation.
  5. If the preceding and following character formats of a consecutive sequence of white-space/punctuation are different, the white-space/punctuation sequence is forcibly unformatted. Combined with per line conversion, this results in:
    1. White-space/punctuation at the start or end of a line being unformatted;
    2. White-space/punctuation at the start or end of a section of formatted text being unformatted.

Notes:

  • The script is fairly well documented, so should it be self explanatory.

  • It uses late-binding so no references need to be set.

EDIT: Updated with new version as per comments.

  • @AlexanderDixon Hmm. I neither do, nor watch (mostly ;-) ) video tutorials. I'll see if a can track one down for you. I do have a link to a Microsoft article with a lot of pretty pictures :-) It shows how to write macros and bind them to a hotkey. Installing a macro is exactly the same. Just copy/paste the code from the answer into the module.The article is for Word 2010, but the process is the same for all versions. (Although the "Customize Keyboard" dialog to set the hotkey is in different places.) – robinCTS May 10 '18 at 13:54
  • I'm running into a case where this macro cannot run due to a 4608 runtime error: value out of range. It seems to be choking on the underline code specifically at If NotJustWhiteSpaceOrPunctuation(rngFound.Parent.Range(rngExpanded.End, rngFound.Start)) Then Exit Do Do you have an email account where I could send the document to you so you can see exactly what is going on? – Alexander Dixon May 11 '18 at 17:06
  • Let us continue this discussion in chat. – Alexander Dixon May 11 '18 at 17:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.