Set "Highlight All Items Found" in Code

[StanC]

I'm trying to figure out how to code a "Find" action that replicates using
the "Highlight All Items Found in..." check box to select all find targets
at once. I'll then copy and paste them to a report.

Code fragment I'm using unsuccessfully so far:

Set myDoc = Documents.Open(.FoundFiles(i))

If FirstLoop Then
ClearFindAndReplaceParameters
Selection.Find.ClearFormatting
With Selection.Find
.Text = "\[????????\]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Set LinkSelect = Selection.Find.Execute
Selection.Find.Execute
If LinkSelect = "" Then
Selection.Copy
Windows("TestReport.doc").Activate
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
Selection.TypeText myDoc.Name & vbCr
Selection.Paste
Selection.TypeParagraph

 

[Doug Robbins]

Hi Stan,

I think that this does what you are after:

Dim myDoc As Document, Target As Document, foundtext As Range
Set Target = Documents.Open("TestReport.Doc")
Set myDoc = Documents.Open(.FoundFiles(i))
myDoc.Activate
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:="\[????????\]", MatchWildcards:=True,
Wrap:=wdFindStop, Forward:=True) = True
Set foundtext = Selection.Range.Text
Target.Range.InsertAfter vbCr & foundtext & vbCr
Loop
End With

--
Please respond to the Newsgroup for the benefit of others who may be
interested. Questions sent directly to me will only be answered on a paid
consulting basis.

Hope this helps,
Doug Robbins - Word MVP

 

[StanC]

Doug,

Thanks for the suggestion. However, it runs into a "Type Mismatch" error
when it hits:
Set foundtext = Selection.Find.Text

Tried changing the variable type to String and substituting .Find for
Range but that didn't work. Any thoughts on how to fix it?

Here's the whole subroutine (with a bunch of other trials commented out).

Public Sub FindTutorLinks()

Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
Dim i As Long
Dim SrchStrng As String
Dim Target As Document
Dim foundtext As Range

Set Target = Documents.Open("TestReport.Doc")


PathToUse = "C:\Documents and Settings\snc2f\My
Documents\Toolbars\Folders\Tutor Macro Tests\TEST EDU"

'Error handler to handle error generated whenever
'the FindReplace dialog is closed

On Error Resume Next

FirstLoop = True

'Set the directory and type of file to batch process
With Application.FileSearch
.NewSearch
.LookIn = PathToUse
.SearchSubFolders = False
.FileName = "EDU*.doc"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() Then

For i = 1 To .FoundFiles.Count

'Open document
Set myDoc = Documents.Open(.FoundFiles(i))

If FirstLoop Then
'ClearFindAndReplaceParameters
myDoc.Activate
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:="\[????????\]",
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
Set foundtext = Selection.Range.Text
Target.Range.InsertAfter vbCr & foundtext & vbCr
Loop
End With


'If Selection.Find.Text = "" Then End If

'Else

'Selection.Copy
'Windows("TestReport.doc").Activate
'Selection.EndKey Unit:=wdStory
'Selection.TypeParagraph
'Selection.TypeText myDoc.Name & vbCr
'Selection.PasteAndFormat (wdPasteDefault)
'Selection.TypeParagraph
'Application.Run MacroName:="Author.FileSave.FileSave"

'End If

'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdDoNotSaveChanges

Next i

End If

End With

End Sub

 

[Chad DeMeyer]

Stan, if:

Dim foundtext As Range

then:

Set foundtext = Selection.Range
Target.Range.InsertAfter vbCr & foundtext.Text & vbCr

Regards,
Chad

 

[StanC]

Still struggling with this one. At the moment the code below stops
executing and complains that TestReport.doc cannot be found. The routine
starts with that document open and it's intended to stay open. I'm stuck
again! Any ideas?

Sub FindTutorLinks_2()

Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim i As Long
Dim SrchStrng As String
Dim Target As Document
Dim foundtext As Range

PathToUse = "C:\Documents and Settings\snc2f\My
Documents\Toolbars\Folders\Tutor Macro Tests\TEST EDU"
Set Target = Documents.Open("TestReport.Doc")

With Application.FileSearch
.NewSearch
.LookIn = PathToUse
.SearchSubFolders = False
.FileName = "EDU*.doc"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() Then

For i = 1 To .FoundFiles.Count
Set myDoc = Documents.Open(.FoundFiles(i))
myDoc.Activate
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:="\[????????\]",
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
Set foundtext = Selection.Range
'Windows("TestReport.doc").Activate
Target.Range.InsertAfter vbCr & foundtext.Text & vbCr
Loop
End With
'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdDoNotSaveChanges

Next i
End If
End With
End Sub

 

[Doug Robbins]

Hi Stan,

If you are starting with TestReport.Doc open, change the line

Set Target = Documents.Open("TestReport.Doc")

to

Set Target = ActiveDocument

--
Please respond to the Newsgroup for the benefit of others who may be
interested. Questions sent directly to me will only be answered on a paid
consulting basis.

Hope this helps,
Doug Robbins - Word MVP