Можно так. Пример использования в макросе TestRangeTextsColor.
Option Compatible
' Раскрашивает различными цветами фрагменты текстов в ячейке.
' - oCell ячейка.
' - aTexts массив фрагментов текстов.
' - entireWords Если True, то раскрашивать только целые слова, иначе фрагменты.
' - aColors массив цветов (той же размерности, что aTexts).
' - matchCase False:происводить поиск слов без учета регистра букв, True - с учетом регистра.
'
Sub CellTextsColor(ByVal oCell, ByVal aTexts, ByVal aColors, Optional Byval entireWords as Boolean, Optional ByVal matchCase As Boolean)
Dim oTextCursor, i As Long, j as Long, j0 as Long, i0 as String, s As String, bFound As Boolean
If IsMissing(matchCase) Then matchCase=False
If IsMissing(entireWords) Then entireWords=False
oTextCursor=oCell.createTextCursor()
s=oCell.String
For i=LBound(aTexts) To UBound(aTexts)
j0=1
Do While j0<=len(s)
If matchCase Then
j=Instr(j0, s, aTexts(i), 0)
Else
j=Instr(j0, lcase(s), lcase(aTexts(i)), 0)
End If
If j>0 Then
bFound=True
If entireWords Then
If j>1 Then
If Ucase(Mid(s, j-1, 1))<>lCase(Mid(s, j-1, 1)) Then bFound=False ' слева от найденного текста - буква
End If
If j+Len(aTexts(i))<=Len(s) Then
If Ucase(Mid(s, j+Len(aTexts(i)), 1))<>lCase(Mid(s, j+Len(aTexts(i)), 1)) Then bFound=False ' справа от найденного текста - буква
End If
End If
If bFound Then
With oTextCursor
.gotoStart False
.goRight j-1 , False
.goRight Len(aTexts(i)), True
.CharColor=aColors(i)
End With
End If
Else
Exit Do
End If
j0=j+Len(aTexts(i))
Loop
Next i
End Sub
' Раскрашивает различными цветами фрагменты текстов в диапазоне(диапазонах) ячеек.
' - oRange ячейка или диапазон ячеек
' - aTexts массив фрагментов текстов.
' - entireWords Если True, то раскрашивать только целые слова, иначе фрагменты.
' - aColors массив цветов (той же размерности, что aTexts).
' - matchCase False:происводить поиск слов без учета регистра букв, True - с учетом регистра.
'
Sub RangeTextsColor(ByVal oRange, ByVal aTexts, ByVal aColors, Optional Byval entireWords as Boolean, Optional ByVal matchCase As Boolean)
Dim oCell
If IsMissing(matchCase) Then matchCase=False
If IsMissing(entireWords) Then entireWords=False
If oRange.supportsService("com.sun.star.sheet.SheetCell") Then
CellTextsColor oRange, aTexts, aColors, entireWords, matchCase
Else
For Each oCell In oRange.queryContentCells(com.sun.star.sheet.CellFlags.STRING).getCells
CellTextsColor oCell, aTexts, aColors, entireWords, matchCase
Next oCell
End If
End Sub
' Раскрашивает в выделенном фрагменте ячеек слова "все", "очень", "сложно".
Sub TestRangeTextsColor
RangeTextsColor ThisComponent.CurrentSelection, Array("все", "очень", "сложно"), Array(RGB(255, 0, 0), RGB(0, 255, 0), RGB(0, 0, 255)),False
End Sub
