alguna vez hice esto...
Option Explicit
'//By JuanC - Ene. 2008
Sub SearchWordsInDoc()
Dim wDoc As Object
Dim wApp As Object
Dim fs As Variant
Dim lCount&, i&, sText$
Dim sFullName$, lOff&
Set fs = Application.FileSearch
Set wApp = GetWord
If wApp Is Nothing Then GoTo Fin
Application.ScreenUpdating = False
sText = "julio" '//Texto a buscar
Set fs = Application.FileSearch
With fs
.LookIn = "c:windowsescritorio" '//Carpeta de búsqueda
.SearchSubFolders = True
.Filename = "*.doc"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then
lCount = .FoundFiles.Count
For i = 1 To lCount
sFullName = .FoundFiles(i)
Set wDoc = wApp.Documents.Open(sFullName)
If Not wDoc Is Nothing Then
If FindText(wDoc, sText) Then
[A1].Offset(lOff).Hyperlinks.Add Anchor:=[A1].Offset(lOff), Address:=wDoc.FullName, TextToDisplay:=Mid(sFullName, InStrRev(sFullName, "") + 1)
lOff = lOff + 1
End If
wDoc.Close False
End If
Next
End If
End With
wApp.Quit
Fin:
Application.ScreenUpdating = True
Set fs = Nothing
Set wApp = Nothing
Set wDoc = Nothing
End Sub
Private Function GetWord() As Object
On Error GoTo Create
Set GetWord = GetObject(, "Word.Application")
Exit Function
Create:
Set GetWord = CreateObject("Word.Application")
End Function
Private Function FindText(ByVal Doc As Object, ByVal sText As String) As Boolean
On Error Resume Next
With Doc.Content.Find
.ClearFormatting
If .Execute(FindText:=sText) Then
FindText = True
Else
FindText = False
End If
End With
End Function
Saludos desde Baires, JuanC
