word macro to hightlight text

V

vonclausowitz

Hi All,

I use this macro in Word to hightlight certain words. Now I want to use
wildcards but it's not possible with the code that I have because it
will replace everything with the wildcards.
Example:

this code searches a txt file with the words to look for. If in the txt
file I place the word:
Ira? the code will scan my document and replace words like Iraq and
Iran with Ira?.

So what I want is that it leaves the word as it is and just highlights
it.

Sub ColorWords(ByVal strText As String, _
ByVal MyColor As Variant)

With ActiveDocument.Content.Find
.ClearFormatting
.MatchWholeWord = True
With .Replacement
.ClearFormatting
.Font.Color = MyColor
.Highlight = True 'highlight the text in yellow
End With
.Execute FindText:=strText, ReplaceWith:=strText, _
Format:=True, Replace:=wdReplaceAll
End With

End Sub


Regards
Marco
 
D

Doug Robbins - Word MVP

You need to use a proper Wildcard search (as distinct from a search using a
wildcard) in which to search for Iraq or Iran or Iraqi or Iaranian, you
would search for Ira[a-z]{1,}

See the article "Finding and replacing characters using wildcards" at:
http://www.word.mvps.org/FAQs/General/UsingWildcards.htm


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP
 
H

Helmut Weber

Hi Marco,

as Doug said, you need a wildcard search.
There is no "matchwildcards" in your code.

As to replacements and highlighting,
I thought I knew how to do it,
but couldn't get it to work.

Maybe it's a matter of style,
maybe I am used to some methods,
and forget about alternatives.

This is the way I'd do it:

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)
' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor
Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = sTmp
.MatchWildcards = True
While .Execute
rDcm.Font.Color = lFnt
rDcm.HighlightColorIndex = lHgh
Wend
End With
End Sub

Sub test8912()
ColorWords "Ira[a-z]{1,}", wdColorRed, wdYellow
End Sub

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"
 
V

vonclausowitz

Helmut,

frohe weihnachten....

I tried your code but I get an error 5560 on the string to search on.
"Ira[a-z]{1,}"
This is what I did:
I tried both your version and the Ira* in my text file but the same
error.
Why is this not working?

Sub GetStartedColoring()

Dim strMyDocuments
Dim arrKeyWords As Variant
Dim arrSplit As Variant
Dim i As Long

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strMyDocuments = objShell.SpecialFolders("MyDocuments")

If Right(strMyDocuments, 1) <> "\" Then
strMyDocuments = strMyDocuments & "\"
End If

If objFSO.FileExists(strMyDocuments & "ColorKeyWords.txt") Then
arrKeyWords = InitFile(strMyDocuments & _
"ColorKeyWords.txt", ";")

For i = 0 To UBound(arrKeyWords)
If arrKeyWords(i) <> "" Then
arrSplit = SplitIt(arrKeyWords(i), "=")
HexValue = ConstConversion(Trim(arrSplit(1)))
ColorWords Trim(arrSplit(0)), wdColorBlack, wdYellow
End If
Next i

Selection.HomeKey Unit:=wdStory, Extend:=False
Else
MsgBox "Could not find " & _
strMyDocuments & "ColorKeyWords.txt . Exiting Macro."
End If

End Sub

Function SplitIt(ByVal strIn As Variant, _
Optional ByVal strDelim As String = " ", _
Optional ByVal lCount As Long = -1) _
As Variant
Dim vOut() As Variant
Dim strSubString As String
Dim k As Integer
Dim lDelimPos As Long

k = 0
lDelimPos = InStr(strIn, strDelim)

Do While (lDelimPos)
' Get everything to the left of the delimiter
strSubString = Left(strIn, lDelimPos - 1)
' Make the return array one element larger
ReDim Preserve vOut(k)
' Add the new element
vOut(k) = strSubString
k = k + 1
If lCount <> -1 And k = lCount Then
SplitIt = vOut
Exit Function
End If
' Only interested in what's right of delimiter
strIn = Right(strIn, (Len(strIn) - _
(lDelimPos + Len(strDelim) - 1)))
' See if delimiter occurs again
lDelimPos = InStr(strIn, strDelim)
Loop

' No more delimiters in string.
' Add what's left as last element
ReDim Preserve vOut(k)
vOut(k) = strIn

SplitIt = vOut
End Function


'===================================================
Function InitFile(HostSource, strComment)

'********************************************************
'Constants for file operations '*
'********************************************************
Const ForReading = 1, ForWriting = 2, ForAppending = 8 '*
'********************************************************


Dim ts
Dim tsLine
Dim arrWords As Variant
Dim strTrim As String

On Error Resume Next

ReDim arrWords(0)

Set ts = objFSO.OpenTextFile(HostSource, ForReading, False)
Do While Not ts.AtEndOfStream
tsLine = Trim(ts.ReadLine)
tsLine = tsLine
If tsLine <> "" And Left(tsLine, 1) <> strComment Then
strTrim = Trim(tsLine)
lngBoundary = UBound(arrWords)
If arrWords(lngBoundary) = "" Then
arrWords(lngBoundary) = strTrim
Else
ReDim Preserve arrWords(lngBoundary + 1)
arrWords(lngBoundary + 1) = strTrim
End If
End If
Loop
ts.Close

InitFile = arrWords

On Error GoTo 0

End Function
Function ConstConversion(ByVal strColor As String)

Select Case strColor

Case "wdColorAqua"
ConstConversion = &HCCCC33
Case "wdColorAutomatic"
ConstConversion = &HFF000000
Case "wdColorBlack"
ConstConversion = 0
Case "wdColorBlue"
ConstConversion = &HFF0000
Case "wdColorBlueGray"
ConstConversion = &H996666
Case "wdColorBrightGreen"
ConstConversion = 65280
Case "wdColorBrown"
ConstConversion = &H3399
Case "wdColorDarkBlue"
ConstConversion = &H800000
Case "wdColorDarkGreen"
ConstConversion = &H3300
Case "wdColorDarkRed"
ConstConversion = &H80
Case "wdColorDarkTeal"
ConstConversion = &H663300
Case "wdColorDarkYellow"
ConstConversion = 32896
Case "wdColorGold"
ConstConversion = 52479
Case "wdColorGray05"
ConstConversion = &HF3F3F3
Case "wdColorGray10"
ConstConversion = &HE6E6E6
Case "wdColorGray125"
ConstConversion = &HE0E0E0
Case "wdColorGray15"
ConstConversion = &HD9D9D9
Case "wdColorGray20"
ConstConversion = &HCCCCCC
Case "wdColorGray25"
ConstConversion = &HC0C0C0
Case "wdColorGray30"
ConstConversion = &HB3B3B3
Case "wdColorGray35"
ConstConversion = &HA6A6A6
Case "wdColorGray375"
ConstConversion = &HA0A0A0
Case "wdColorGray40"
ConstConversion = &H999999
Case "wdColorGray45"
ConstConversion = &H8C8C8C
Case "wdColorGray50"
ConstConversion = &H808080
Case "wdColorGray55"
ConstConversion = &H737373
Case "wdColorGray60"
ConstConversion = &H666666
Case "wdColorGray625"
ConstConversion = &H606060
Case "wdColorGray65"
ConstConversion = &H656565
Case "wdColorGray70"
ConstConversion = &H4C4C4C
Case "wdColorGray75"
ConstConversion = &H404040
Case "wdColorGray80"
ConstConversion = &H333333
Case "wdColorGray85"
ConstConversion = &H262626
Case "wdColorGray875"
ConstConversion = &H202020
Case "wdColorGray90"
ConstConversion = &H191919
Case "wdColorGray95"
ConstConversion = 789516
Case "wdColorGreen"
ConstConversion = 32768
Case "wdColorIndigo"
ConstConversion = &H993333
Case "wdColorLavender"
ConstConversion = &HFF99CC
Case "wdColorLightBlue"
ConstConversion = &HFF6633
Case "wdColorLightGreen"
ConstConversion = &HCCFFCC
Case "wdColorLightOrange"
ConstConversion = 39423
Case "wdColorLightTurquoise"
ConstConversion = &HFFFFCC
Case "wdColorLightYellow"
ConstConversion = &H99FFFF
Case "wdColorLime"
ConstConversion = 52377
Case "wdColorOliveGreen"
ConstConversion = 13107
Case "wdColorOrange"
ConstConversion = 26367
Case "wdColorPaleBlue"
ConstConversion = &HFFCC99
Case "wdColorPink"
ConstConversion = &HFF00FF
Case "wdColorPlum"
ConstConversion = 6697881
Case "wdColorRed"
ConstConversion = 255
Case "wdColorRose"
ConstConversion = &HCC99FF
Case "wdColorSeaGreen"
ConstConversion = &H669933
Case "wdColorSkyBlue"
ConstConversion = &HFFCC00
Case "wdColorTan"
ConstConversion = &H99CCFF
Case "wdColorTeal"
ConstConversion = &H808000
Case "wdColorTurquoise"
ConstConversion = &HFFFF00
Case "wdColorViolet"
ConstConversion = &H800080
Case "wdColorWhite"
ConstConversion = &HFFFFFF
Case "wdColorYellow"
ConstConversion = 65535
Case Else
ConstConversion = 0
End Select

End Function

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)

' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor
Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = sTmp
.MatchWildcards = True
While .Execute
rDcm.Font.Color = lFnt
rDcm.HighlightColorIndex = lHgh
Wend
End With

End Sub

And in a text file I put this:

Ira[a-z]{1,}=wdColorDarkYellow

;Valid color keywords
;wdColorAqua = &HCCCC33
;wdColorAutomatic = &HFF000000
;wdColorBlack = 0
;wdColorBlue=&HFF0000
;wdColorBlueGray = &H996666
;wdColorBrightGreen = &HFF00
;wdColorBrown = &H3399
;wdColorDarkBlue = &H800000
;wdColorDarkGreen = &H3300
;wdColorDarkRed = &H80
;wdColorDarkTeal = &H663300
;wdColorDarkYellow = &H8080
;wdColorGold = &HCCFF
;wdColorGray05 = &HF3F3F3
;wdColorGray10 = &HE6E6E6
;wdColorGray125 = &HE0E0E0
;wdColorGray15 = &HD9D9D9
;wdColorGray20 = &HCCCCCC
;wdColorGray25 = &HC0C0C0
;wdColorGray30 = &HB3B3B3
;wdColorGray35 = &HA6A6A6
;wdColorGray375 = &HA0A0A0
;wdColorGray40 = &H999999
;wdColorGray45 = &H8C8C8C
;wdColorGray50 = &H808080
;wdColorGray55 = &H737373
;wdColorGray60 = &H666666
;wdColorGray625 = &H606060
;wdColorGray65 = &H656565
;wdColorGray70 = &H4C4C4C
;wdColorGray75 = &H404040
;wdColorGray80 = &H333333
;wdColorGray85 = &H262626
;wdColorGray875 = &H202020
;wdColorGray90 = &H191919
;wdColorGray95 = &HC0C0C
;wdColorGreen = &H8000
;wdColorIndigo = &H993333
;wdColorLavender = &HFF99CC
;wdColorLightBlue = &HFF6633
;wdColorLightGreen = &HCCFFCC
;wdColorLightOrange = &H99FF
;wdColorLightTurquoise = &HFFFFCC
;wdColorLightYellow = &H99FFFF
;wdColorLime = 52377
;wdColorOliveGreen = &H3333
;wdColorOrange = &H66FF
;wdColorPaleBlue = &HFFCC99
;wdColorPink = &HFF00FF
;wdColorPlum = &H663399
;wdColorRed = &HFF
;wdColorRose = &HCC99FF
;wdColorSeaGreen = &H669933
;wdColorSkyBlue = &HFFCC00
;wdColorTan = &H99CCFF
;wdColorTeal = &H808080
;wdColorTurquoise = &HFFFF00
;wdColorViolet = &H800080
;wdColorWhite = &HFFFFFF
;wdColorYellow = &HFFFF

Regards
Marco
The Netherlands
 
D

Doug Robbins - Word MVP

The following modification of Helmut's code applies the colouring to all
words in a document that match the wildcard search criteria

e.g. Iran Iraq, Iranian, Iraqi

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)
' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:=sTmp, MatchWildcards:=True,
Wrap:=wdFindStop, Forward:=True) = True
Selection.Range.Font.Color = lFnt
Selection.Range.HighlightColorIndex = lHgh
Selection.Collapse wdCollapseEnd
Loop
End With
End Sub

Sub test8912()
ColorWords "Ira[a-z]{1,}", wdColorRed, wdYellow
End Sub

..
--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

Helmut,

frohe weihnachten....

I tried your code but I get an error 5560 on the string to search on.
"Ira[a-z]{1,}"
This is what I did:
I tried both your version and the Ira* in my text file but the same
error.
Why is this not working?

Sub GetStartedColoring()

Dim strMyDocuments
Dim arrKeyWords As Variant
Dim arrSplit As Variant
Dim i As Long

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strMyDocuments = objShell.SpecialFolders("MyDocuments")

If Right(strMyDocuments, 1) <> "\" Then
strMyDocuments = strMyDocuments & "\"
End If

If objFSO.FileExists(strMyDocuments & "ColorKeyWords.txt") Then
arrKeyWords = InitFile(strMyDocuments & _
"ColorKeyWords.txt", ";")

For i = 0 To UBound(arrKeyWords)
If arrKeyWords(i) <> "" Then
arrSplit = SplitIt(arrKeyWords(i), "=")
HexValue = ConstConversion(Trim(arrSplit(1)))
ColorWords Trim(arrSplit(0)), wdColorBlack, wdYellow
End If
Next i

Selection.HomeKey Unit:=wdStory, Extend:=False
Else
MsgBox "Could not find " & _
strMyDocuments & "ColorKeyWords.txt . Exiting Macro."
End If

End Sub

Function SplitIt(ByVal strIn As Variant, _
Optional ByVal strDelim As String = " ", _
Optional ByVal lCount As Long = -1) _
As Variant
Dim vOut() As Variant
Dim strSubString As String
Dim k As Integer
Dim lDelimPos As Long

k = 0
lDelimPos = InStr(strIn, strDelim)

Do While (lDelimPos)
' Get everything to the left of the delimiter
strSubString = Left(strIn, lDelimPos - 1)
' Make the return array one element larger
ReDim Preserve vOut(k)
' Add the new element
vOut(k) = strSubString
k = k + 1
If lCount <> -1 And k = lCount Then
SplitIt = vOut
Exit Function
End If
' Only interested in what's right of delimiter
strIn = Right(strIn, (Len(strIn) - _
(lDelimPos + Len(strDelim) - 1)))
' See if delimiter occurs again
lDelimPos = InStr(strIn, strDelim)
Loop

' No more delimiters in string.
' Add what's left as last element
ReDim Preserve vOut(k)
vOut(k) = strIn

SplitIt = vOut
End Function


'===================================================
Function InitFile(HostSource, strComment)

'********************************************************
'Constants for file operations '*
'********************************************************
Const ForReading = 1, ForWriting = 2, ForAppending = 8 '*
'********************************************************


Dim ts
Dim tsLine
Dim arrWords As Variant
Dim strTrim As String

On Error Resume Next

ReDim arrWords(0)

Set ts = objFSO.OpenTextFile(HostSource, ForReading, False)
Do While Not ts.AtEndOfStream
tsLine = Trim(ts.ReadLine)
tsLine = tsLine
If tsLine <> "" And Left(tsLine, 1) <> strComment Then
strTrim = Trim(tsLine)
lngBoundary = UBound(arrWords)
If arrWords(lngBoundary) = "" Then
arrWords(lngBoundary) = strTrim
Else
ReDim Preserve arrWords(lngBoundary + 1)
arrWords(lngBoundary + 1) = strTrim
End If
End If
Loop
ts.Close

InitFile = arrWords

On Error GoTo 0

End Function
Function ConstConversion(ByVal strColor As String)

Select Case strColor

Case "wdColorAqua"
ConstConversion = &HCCCC33
Case "wdColorAutomatic"
ConstConversion = &HFF000000
Case "wdColorBlack"
ConstConversion = 0
Case "wdColorBlue"
ConstConversion = &HFF0000
Case "wdColorBlueGray"
ConstConversion = &H996666
Case "wdColorBrightGreen"
ConstConversion = 65280
Case "wdColorBrown"
ConstConversion = &H3399
Case "wdColorDarkBlue"
ConstConversion = &H800000
Case "wdColorDarkGreen"
ConstConversion = &H3300
Case "wdColorDarkRed"
ConstConversion = &H80
Case "wdColorDarkTeal"
ConstConversion = &H663300
Case "wdColorDarkYellow"
ConstConversion = 32896
Case "wdColorGold"
ConstConversion = 52479
Case "wdColorGray05"
ConstConversion = &HF3F3F3
Case "wdColorGray10"
ConstConversion = &HE6E6E6
Case "wdColorGray125"
ConstConversion = &HE0E0E0
Case "wdColorGray15"
ConstConversion = &HD9D9D9
Case "wdColorGray20"
ConstConversion = &HCCCCCC
Case "wdColorGray25"
ConstConversion = &HC0C0C0
Case "wdColorGray30"
ConstConversion = &HB3B3B3
Case "wdColorGray35"
ConstConversion = &HA6A6A6
Case "wdColorGray375"
ConstConversion = &HA0A0A0
Case "wdColorGray40"
ConstConversion = &H999999
Case "wdColorGray45"
ConstConversion = &H8C8C8C
Case "wdColorGray50"
ConstConversion = &H808080
Case "wdColorGray55"
ConstConversion = &H737373
Case "wdColorGray60"
ConstConversion = &H666666
Case "wdColorGray625"
ConstConversion = &H606060
Case "wdColorGray65"
ConstConversion = &H656565
Case "wdColorGray70"
ConstConversion = &H4C4C4C
Case "wdColorGray75"
ConstConversion = &H404040
Case "wdColorGray80"
ConstConversion = &H333333
Case "wdColorGray85"
ConstConversion = &H262626
Case "wdColorGray875"
ConstConversion = &H202020
Case "wdColorGray90"
ConstConversion = &H191919
Case "wdColorGray95"
ConstConversion = 789516
Case "wdColorGreen"
ConstConversion = 32768
Case "wdColorIndigo"
ConstConversion = &H993333
Case "wdColorLavender"
ConstConversion = &HFF99CC
Case "wdColorLightBlue"
ConstConversion = &HFF6633
Case "wdColorLightGreen"
ConstConversion = &HCCFFCC
Case "wdColorLightOrange"
ConstConversion = 39423
Case "wdColorLightTurquoise"
ConstConversion = &HFFFFCC
Case "wdColorLightYellow"
ConstConversion = &H99FFFF
Case "wdColorLime"
ConstConversion = 52377
Case "wdColorOliveGreen"
ConstConversion = 13107
Case "wdColorOrange"
ConstConversion = 26367
Case "wdColorPaleBlue"
ConstConversion = &HFFCC99
Case "wdColorPink"
ConstConversion = &HFF00FF
Case "wdColorPlum"
ConstConversion = 6697881
Case "wdColorRed"
ConstConversion = 255
Case "wdColorRose"
ConstConversion = &HCC99FF
Case "wdColorSeaGreen"
ConstConversion = &H669933
Case "wdColorSkyBlue"
ConstConversion = &HFFCC00
Case "wdColorTan"
ConstConversion = &H99CCFF
Case "wdColorTeal"
ConstConversion = &H808000
Case "wdColorTurquoise"
ConstConversion = &HFFFF00
Case "wdColorViolet"
ConstConversion = &H800080
Case "wdColorWhite"
ConstConversion = &HFFFFFF
Case "wdColorYellow"
ConstConversion = 65535
Case Else
ConstConversion = 0
End Select

End Function

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)

' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor
Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = sTmp
.MatchWildcards = True
While .Execute
rDcm.Font.Color = lFnt
rDcm.HighlightColorIndex = lHgh
Wend
End With

End Sub

And in a text file I put this:

Ira[a-z]{1,}=wdColorDarkYellow

;Valid color keywords
;wdColorAqua = &HCCCC33
;wdColorAutomatic = &HFF000000
;wdColorBlack = 0
;wdColorBlue=&HFF0000
;wdColorBlueGray = &H996666
;wdColorBrightGreen = &HFF00
;wdColorBrown = &H3399
;wdColorDarkBlue = &H800000
;wdColorDarkGreen = &H3300
;wdColorDarkRed = &H80
;wdColorDarkTeal = &H663300
;wdColorDarkYellow = &H8080
;wdColorGold = &HCCFF
;wdColorGray05 = &HF3F3F3
;wdColorGray10 = &HE6E6E6
;wdColorGray125 = &HE0E0E0
;wdColorGray15 = &HD9D9D9
;wdColorGray20 = &HCCCCCC
;wdColorGray25 = &HC0C0C0
;wdColorGray30 = &HB3B3B3
;wdColorGray35 = &HA6A6A6
;wdColorGray375 = &HA0A0A0
;wdColorGray40 = &H999999
;wdColorGray45 = &H8C8C8C
;wdColorGray50 = &H808080
;wdColorGray55 = &H737373
;wdColorGray60 = &H666666
;wdColorGray625 = &H606060
;wdColorGray65 = &H656565
;wdColorGray70 = &H4C4C4C
;wdColorGray75 = &H404040
;wdColorGray80 = &H333333
;wdColorGray85 = &H262626
;wdColorGray875 = &H202020
;wdColorGray90 = &H191919
;wdColorGray95 = &HC0C0C
;wdColorGreen = &H8000
;wdColorIndigo = &H993333
;wdColorLavender = &HFF99CC
;wdColorLightBlue = &HFF6633
;wdColorLightGreen = &HCCFFCC
;wdColorLightOrange = &H99FF
;wdColorLightTurquoise = &HFFFFCC
;wdColorLightYellow = &H99FFFF
;wdColorLime = 52377
;wdColorOliveGreen = &H3333
;wdColorOrange = &H66FF
;wdColorPaleBlue = &HFFCC99
;wdColorPink = &HFF00FF
;wdColorPlum = &H663399
;wdColorRed = &HFF
;wdColorRose = &HCC99FF
;wdColorSeaGreen = &H669933
;wdColorSkyBlue = &HFFCC00
;wdColorTan = &H99CCFF
;wdColorTeal = &H808080
;wdColorTurquoise = &HFFFF00
;wdColorViolet = &H800080
;wdColorWhite = &HFFFFFF
;wdColorYellow = &HFFFF

Regards
Marco
The Netherlands
Click to expand...
 
H

Helmut Weber

Hi Marco,

the comma in the search pattern is a semikolon ";"
in Germany, the Netherlands, and some other countries.
I'm using a US-version.

I did not look in the rest of the code.

Frohe Weinhacht.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"
 
V

vonclausowitz

Helmut,

It's working now with the searchstring: Ira[a-z]{1;}=wdColorDarkYellow

But the code stops after it finds the first word Iran.

I also tried the MatchWholeWord but that doesn't help.

Do While .Execute(FindText:=sTmp, MatchWholeWord:=True,
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True

Marco
 
H

Helmut Weber

Hi Marco,

that's really a lot of code,
some of which doesn't make sense to me.

Do you want to search the whole doc?
Then there is no need for a selection object,
no need for Wrap:=wdFindStop,
no need for Forward:=True
and all other parameters except matchwildcards,
and the search string.

Searching and highlighting Ira[a-z]{1;} works
right here and now, (with a comma for me, of course).

I can't see where the "=wdColorDarkYellow" comes in.

Further more, this seems much too much code for me.

"Hexvalue" doesn't to anything and is never declared.
So even ConstConversion doesn't do anything,
as the result as that function is never used either.

Avoid "variant".
A function should return something with a data type.

Is it, that you want to set the highlightcolor
of certain character patterns, defined in a text file?

Then I'd usesomething like:

I[a-z]{1,}=&H8080
F[a-z]{1,}=&H8080
L[a-z]{1,}=&H66FF

Whether you use a string representing a number
in hex-notation or binary or decimal doesn't matter.

hmm... difficult, but I like it.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"
 
V

vonclausowitz

Helmut,

Yes I want to search the whole doc. But not just on one thing. I want
to be able to search on several strings. That's why I have this
txt-file with all the words.

[helmut wrote] I can't see where the "=wdColorDarkYellow" comes in.
that's because most people do not know what something like &H8080
stands for.
It is in the textfile and gets translated in the code to Hex.

Is it, that you want to set the highlightcolor
of certain character patterns, defined in a text file?

[Helmut wrote] Then I'd usesomething like:
I[a-z]{1,}=&H8080
F[a-z]{1,}=&H8080
L[a-z]{1,}=&H66FF

Yes I do.....
How would my code look like?
Searching on multiple strings that I define in this textfile.

Marco
 
V

vonclausowitz

Helmut,

I played around a bit and got things working. I skipped a lot of code
and ended up with this:
The only thing I have to learn is setting the wildcards. Can you
explain me how the codes work?

Ira[a-z]{1;}
[a-z]tt[a-z]{1;}

Can I use {1;) in front also and what does the number mean exactly?
Can I use {10;} and what does it do?

Public objFSO As Object
Public objShell As Object

Sub GetStartedColoring()

Dim strMyDocuments
Dim arrKeyWords As Variant
Dim arrSplit As Variant
Dim i As Long

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strMyDocuments = objShell.SpecialFolders("MyDocuments")

If Right(strMyDocuments, 1) <> "\" Then
strMyDocuments = strMyDocuments & "\"
End If

If objFSO.FileExists(strMyDocuments & "ColorKeyWords.txt") Then
arrKeyWords = InitFile(strMyDocuments & _
"ColorKeyWords.txt", ";")

For i = 0 To UBound(arrKeyWords)
If arrKeyWords(i) <> "" Then
ColorWords Trim(arrKeyWords(i)), wdColorBlack, wdYellow
End If
Next i

Selection.HomeKey Unit:=wdStory, Extend:=False
Else
MsgBox "Could not find " & _
strMyDocuments & "ColorKeyWords.txt . Exiting Macro."
End If

End Sub
Function InitFile(HostSource, strComment)

'Constants for file operations '*
Const ForReading = 1, ForWriting = 2, ForAppending = 8 '*

Dim ts
Dim tsLine
Dim arrWords As Variant
Dim strTrim As String

On Error Resume Next

ReDim arrWords(0)

Set ts = objFSO.OpenTextFile(HostSource, ForReading, False)
Do While Not ts.AtEndOfStream
tsLine = Trim(ts.ReadLine)
tsLine = tsLine
If tsLine <> "" And Left(tsLine, 1) <> strComment Then
strTrim = Trim(tsLine)
lngBoundary = UBound(arrWords)
If arrWords(lngBoundary) = "" Then
arrWords(lngBoundary) = strTrim
Else
ReDim Preserve arrWords(lngBoundary + 1)
arrWords(lngBoundary + 1) = strTrim
End If
End If
Loop
ts.Close

InitFile = arrWords
On Error GoTo 0

End Function

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)

' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor

Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = sTmp
.MatchWildcards = True
While .Execute
rDcm.Font.Color = lFnt
rDcm.HighlightColorIndex = lHgh
Wend
End With

End Sub

Regards
Marco
 
D

Doug Robbins - Word MVP

The use of the wildcard search is all explained in the article "Finding and
replacing characters using wildcards" at:

http://www.word.mvps.org/FAQs/General/UsingWildcards.htm

to which I referred you in my response to your initial post.

[a-z]{1;} means one or more occurences of any letter in the range a to z

[a-z]tt[a-z]{1;} is not a valid wildcard search string

If you wanted to select words such as:

attraction
attention
inattention

you would use:

[a-z]{1;}tt[a-z]{1;}
--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

Helmut,

I played around a bit and got things working. I skipped a lot of code
and ended up with this:
The only thing I have to learn is setting the wildcards. Can you
explain me how the codes work?

Ira[a-z]{1;}
[a-z]tt[a-z]{1;}

Can I use {1;) in front also and what does the number mean exactly?
Can I use {10;} and what does it do?

Public objFSO As Object
Public objShell As Object

Sub GetStartedColoring()

Dim strMyDocuments
Dim arrKeyWords As Variant
Dim arrSplit As Variant
Dim i As Long

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strMyDocuments = objShell.SpecialFolders("MyDocuments")

If Right(strMyDocuments, 1) <> "\" Then
strMyDocuments = strMyDocuments & "\"
End If

If objFSO.FileExists(strMyDocuments & "ColorKeyWords.txt") Then
arrKeyWords = InitFile(strMyDocuments & _
"ColorKeyWords.txt", ";")

For i = 0 To UBound(arrKeyWords)
If arrKeyWords(i) <> "" Then
ColorWords Trim(arrKeyWords(i)), wdColorBlack, wdYellow
End If
Next i

Selection.HomeKey Unit:=wdStory, Extend:=False
Else
MsgBox "Could not find " & _
strMyDocuments & "ColorKeyWords.txt . Exiting Macro."
End If

End Sub
Function InitFile(HostSource, strComment)

'Constants for file operations '*
Const ForReading = 1, ForWriting = 2, ForAppending = 8 '*

Dim ts
Dim tsLine
Dim arrWords As Variant
Dim strTrim As String

On Error Resume Next

ReDim arrWords(0)

Set ts = objFSO.OpenTextFile(HostSource, ForReading, False)
Do While Not ts.AtEndOfStream
tsLine = Trim(ts.ReadLine)
tsLine = tsLine
If tsLine <> "" And Left(tsLine, 1) <> strComment Then
strTrim = Trim(tsLine)
lngBoundary = UBound(arrWords)
If arrWords(lngBoundary) = "" Then
arrWords(lngBoundary) = strTrim
Else
ReDim Preserve arrWords(lngBoundary + 1)
arrWords(lngBoundary + 1) = strTrim
End If
End If
Loop
ts.Close

InitFile = arrWords
On Error GoTo 0

End Function

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)

' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor

Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = sTmp
.MatchWildcards = True
While .Execute
rDcm.Font.Color = lFnt
rDcm.HighlightColorIndex = lHgh
Wend
End With

End Sub

Regards
Marco
Click to expand...
 
H

Helmut Weber

Hi Marco
I played around a bit and got things working.
Click to expand...

Fine :)
The only thing I have to learn is setting the wildcards.
Can you explain me how the codes work?

Ira[a-z]{1;}
[a-z]tt[a-z]{1;}
Click to expand...
Can I use {1;) in front also No.
and what does the number mean exactly?
Can I use {10;} and what does it do?
Click to expand...

If the listseparator is ";"
which can be checked using
Application.International(wdListSeparator)

then
[a-z]{1;} finds 1 or more characters in the range from "a" to "z"
[a-z]{10;} finds 10 or more characters in the range from "a" to "z"

See:
http://word.mvps.org/faqs/general/UsingWildcards.htm
Still more info here:
http://www.gmayor.com/replace_using_wildcards.htm
and note the section on "Gremlins to be aware of ..."

Not everybody likes wildcards.
Visit: microsoft.public.de.word.vba
MVP Thomas Gahler, one of the very very advanced,
whom I regard as my teacher, seems to avoid them altogether.

MVP Klaus Linke, contributing in german and english groups,
however, is a master in using wildcards.
What he wouldn't be, if he didn't like them.

I personally don't like too complicated wildcard patterns
and I code searches rather on a lower level, which is less buggy, too.
But what we have used in your case is very simple.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"
 
V

vonclausowitz

Hello Doug,

Thanks for the explanation.
However your example of:

[a-z]{1;}uze[a-z]{1;}

doesn't return anything in my code.

Only in this form:
[a-z]uze[a-z]{1;}

it will return for example :huzestan
Can't seem to get the search for words with "uze" in the middle right.

Marco
 
H

Helmut Weber

Hi Marco

try:

[a-z]@uze[a-z]{1;}

That seems to be one of the reasons,
why some people mistrust wildcard searches.

Hi Doug, hoping you don't mind adding my "2 cents worth", :)
an expression, I've learned recently.
Is that common use in English?

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"
 
D

Doug Robbins - Word MVP

I am not sure why that doesn't work. I would have thought that it would.
The following does however find huzestan

[a-z]{1;1}uze[a-z]{1;}

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP
 
V

vonclausowitz

Not with me it doesn't.
Is it maybe the code I'm using that's calling this indifference?

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)

' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor

Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = sTmp
.MatchWildcards = True
While .Execute
rDcm.Font.Color = lFnt
rDcm.HighlightColorIndex = lHgh
Wend
End With

End Sub
 
D

Doug Robbins - Word MVP

Using the following modified version of the code that Helmut posted:

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)
' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:=sTmp, MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
Selection.Range.Font.Color = lFnt
Selection.Range.HighlightColorIndex = lHgh
Selection.Collapse wdCollapseEnd
Loop
End With
End Sub

Sub test8912()
ColorWords "[a-z]{1,1}uze[a-z]{1,}", wdColorRed, wdYellow
End Sub

each instance of the word huzestan that I inserted into a document had the
colour of its font changed the red and a high-light colour of yellow
applied. So I think that it may be something to do with the code.

Interestingly though, using [a-z]{1,5}uze[a-z]{1,} which should find between
1 and 5 instances of any lower case letter before the uze does not find
huzestan. It does however find abcdhuzestan and mnophuzestan (5 lower case
letters before uze), but not abdhuzestan (4 lowercase letters before uze.

I am not sure how many words there are with a variable number of lowercase
letters before and after uze, but using:

Sub ColorWords(sTmp As String, lFnt As Long, lHgh As Long)
' sTmp = a temporary string
' lFnt = the color of the font
' lHgh = the highlightcolor
Dim colrange As Range
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:=sTmp, MatchWildcards:=False, _ 'note
MatchWildcards set to False
Wrap:=wdFindStop, Forward:=True) = True
Set colrange = Selection.Range.Words(1)
colrange.Font.Color = lFnt
colrange.HighlightColorIndex = lHgh
Selection.Collapse wdCollapseEnd
Loop
End With
End Sub

Sub test8912()
ColorWords "uze", wdColorRed, wdYellow
End Sub

will apply the colouring to anyword that contains uze.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP
 
V

vonclausowitz

I tried both codes and I think I like the first one better. Although
one can always choose to search with- or without Wildcards.

I was wondering when you have a lot of words to search on. Can you give
them different colours?

For i = 0 To UBound(arrKeyWords)
If arrKeyWords(i) <> "" Then
ColorWords Trim(arrKeyWords(i)), wdColorBlack, wdYellow
End If
Next i

So instead of saying wdYellow all the time for every different word
have a random colour like Google does when I search the newsgroups?

Marco
 
D

Doug Robbins - Word MVP

Almost certainly, the answer is yes. I don't have the code for it at my
fingertips though. You could have another array of colours and use the Rnd
function to randomly grab a colour from the array. Here's a bit of the help
file information on it:

To produce random integers in a given range, use this formula:

Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Here, upperbound is the highest number in the range, and lowerbound is the
lowest number in the range.


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Change a great number of words in word files, with a macro as short as possible. 5
Need help modifying code 0
Word Macro for multiple searches, incl. in footnotes 2
VBA-Table Word 2019 - Move a selected text, from a cell to the adjacent cell to its right, by pressing the ENTER key 0
VBA to look for more than 1 key word and highlights 8
CleanUpPastedText() 1
Macro to Select text from a point given to a specific word 2
vba Word 2003 modify headers 2

Top