find and copy all highlights of a particular color

[Rodney Atkins]

Hi all.

I'm working with a long document in which "glossary" words have all
been highlighted bright green. I would like to copy all of these words
into a separate document so that I can create the glossary.

I'm sure that Word has built-in features that would be a better choice
for this task, but I have to remain within this particular scheme, so
I'm just trying to make my job a little easier.

I have an old WordBasic macro that finds all the occurences of a
particular text string and appends them into a text document, one by
one, but I can't quite figure out how to do the same in VBA and then
modify the search, and I don't think WordBasic supports a search for a
particular highlight color.

Can anyone point me in the right direction?

Thanks.

Rodney

 

[Greg Maxey]

Rodney

See if replacing the msgbox line in the below code with your code to append
to a text document will work:

Sub ScratchMacro1()
Dim rngstory As Word.Range
Set rngstory = ActiveDocument.Range
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Highlight = True
While .Execute
If rngstory.HighlightColorIndex = wdBrightGreen Then
MsgBox rngstory
End If
Wend
End With
End Sub

 

[Rodney Atkins]

Greg:

Well, something happened, but I'm not sure quite what. I got another
file, but it had only an odd collection of characters:

[Hard Return]
{14 spaces}[Hard Return]
[Hard Return]
[Box Character][Hard Return]

About 2 and half pages of that, repeated.

Here's the macro all in one piece. Note that I have not bothered to
change the wordbasic portions.

Sub ScratchMacro1()
Dim file$
Dim dot
Dim prefix$

Dim rngstory As Word.Range
Set rngstory = ActiveDocument.Range

Rem Get the current path and filename and change extension to '.gls'
Rem
file$ = WordBasic.[FileName$]()
dot = InStr(file$, ".")
If dot > 1 Then
prefix$ = WordBasic.[Left$](file$, dot - 1)
Else
prefix$ = file$
End If
file$ = prefix$
file$ = LCase(file$) + ".gls"

With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Highlight = True
While .Execute
If rngstory.HighlightColorIndex = wdBrightGreen Then
Open WordBasic.[CleanString$](file$) For Append As 1
Print #1, WordBasic.[Selection$](), Chr(13)
Close 1
End If
Wend
End With
End Sub

 

[Greg Maxey]

Rodney,

I don't have a clue about wordbasic. I never used it. I dug around in the
VBA help file and stumbled on a WriteLine process. You want a text file
with the list of your hightlighted words correct? This seems to work:

Sub ScratchMacro1()
Dim fs
Dim wordLog
Set fs = CreateObject("Scripting.FileSystemObject")
Set wordLog = fs.CreateTextFile("c:\testfile.txt", True)
Dim rngstory As Word.Range
Set rngstory = ActiveDocument.Range
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Highlight = True
While .Execute
If rngstory.HighlightColorIndex = wdBrightGreen Then
wordLog.WriteLine rngstory
End If
Wend
End With
wordLog.Close
End Sub

--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Greg:

Well, something happened, but I'm not sure quite what. I got another
file, but it had only an odd collection of characters:

[Hard Return]
{14 spaces}[Hard Return]
[Hard Return]
[Box Character][Hard Return]

About 2 and half pages of that, repeated.

Here's the macro all in one piece. Note that I have not bothered to
change the wordbasic portions.

Sub ScratchMacro1()
Dim file$
Dim dot
Dim prefix$

Dim rngstory As Word.Range
Set rngstory = ActiveDocument.Range

Rem Get the current path and filename and change extension to '.gls'
Rem
file$ = WordBasic.[FileName$]()
dot = InStr(file$, ".")
If dot > 1 Then
prefix$ = WordBasic.[Left$](file$, dot - 1)
Else
prefix$ = file$
End If
file$ = prefix$
file$ = LCase(file$) + ".gls"

With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Highlight = True
While .Execute
If rngstory.HighlightColorIndex = wdBrightGreen Then
Open WordBasic.[CleanString$](file$) For Append As 1
Print #1, WordBasic.[Selection$](), Chr(13)
Close 1
End If
Wend
End With
End Sub

Rodney

See if replacing the msgbox line in the below code with your code to
append to a text document will work:

Sub ScratchMacro1()
Dim rngstory As Word.Range
Set rngstory = ActiveDocument.Range
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Highlight = True
While .Execute
If rngstory.HighlightColorIndex = wdBrightGreen Then
MsgBox rngstory
End If
Wend
End With
End Sub

 

[Rodney Atkins]

That works!

Thanks.