I think it's better to handle text between single quotes separately.
Code: Select all
Sub Format_Textbox_Lines()
Dim tfrTextFrame As TextFrame
Dim strText As String
Dim rgbPink As Long
Dim rgbBlue As Long
Dim rgbRed As Long
rgbBlue = RGB(0, 0, 255) ' blue
rgbPink = RGB(255, 0, 255) ' pink
rgbRed = RGB(255, 0, 0) ' red
Dim myBlueArray As Variant
myBlueArray = Array("Blue", "Blue01", "Blue02", "Blue03")
Dim myPinkArray As Variant
myPinkArray = Array("Pink", "Pink01", "Pink02", "Pink03")
Dim myRedText As String
myRedText = "'[^']*'"
Set tfrTextFrame = Sheets("Sheet1").Shapes("TextBox 1").TextFrame
' Clear formatting
tfrTextFrame.Characters.Font.Bold = False
tfrTextFrame.Characters.Font.color = vbBlack
'Format based on arrays
FormatWords tfrTextFrame, myBlueArray, rgbBlue
FormatWords tfrTextFrame, myPinkArray, rgbPink
FormatQuoted tfrTextFrame, myRedText, rgbRed
End Sub
Sub FormatWords(tfrTextFrame As TextFrame, wordsArray As Variant, color As Long)
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = True
Dim word As Variant
Dim matches As Object
Dim match As Object
For Each word In wordsArray
regex.Pattern = "\b" & word & "\b" ' Match whole word
If regex.test(tfrTextFrame.Characters.Text) Then
Set matches = regex.Execute(tfrTextFrame.Characters.Text)
For Each match In matches
tfrTextFrame.Characters(match.FirstIndex + 1, Len(match.Value)).Font.color = color
tfrTextFrame.Characters(match.FirstIndex + 1, Len(match.Value)).Font.Bold = True
Next match
End If
DoEvents
Next word
End Sub
Sub FormatQuoted(tfrTextFrame As TextFrame, word As String, color As Long)
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = True
regex.Pattern = word
Dim matches As Object
Dim match As Object
If regex.test(tfrTextFrame.Characters.Text) Then
Set matches = regex.Execute(tfrTextFrame.Characters.Text)
For Each match In matches
tfrTextFrame.Characters(match.FirstIndex + 1, Len(match.Value)).Font.color = color
tfrTextFrame.Characters(match.FirstIndex + 1, Len(match.Value)).Font.Bold = True
Next match
End If
End Sub