Option Explicit
'Need a reference to MS Scripting Runtime
Sub Initialize(ByRef WDApp As Object, ByRef IStartedWord As Boolean, _
OutputCell As Range)
On Error Resume Next
Set WDApp = GetObject(, "word.application")
On Error GoTo 0
If WDApp Is Nothing Then
IStartedWord = True
Set WDApp = CreateObject("word.application")
End If
Set OutputCell = Workbooks.Add().Worksheets.Add().Range("a1")
End Sub
Sub Shutdown(WDApp As Object, IStartedWord As Boolean)
On Error Resume Next
If IStartedWord Then
WDApp.Quit
End If
Set WDApp = Nothing
End Sub
Function getFileList(aDir As String) As Scripting.Files
Dim x As Scripting.FileSystemObject, aFolder As Scripting.Folder
Set x = New Scripting.FileSystemObject
Set aFolder = x.GetFolder(aDir)
Set getFileList = aFolder.Files
End Function
Function TokenFound(aFile As Scripting.File, _
ByVal SearchToken As String, WDApp As Object)
Dim x As Object
If InStr(1, aFile.Type, "Microsoft word document", vbTextCompare) <= 0 Then
TokenFound = False
Exit Function
End If
Set x = WDApp.documents.Open(aFile.Path)
With x.Content.Find
.ClearFormatting
.Replacement.Text = ""
.Forward = True
'.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
TokenFound = .Execute(SearchToken)
End With
x.Close False
End Function
Sub AddThisFile(ByRef OutputCell As Range, aFile As Scripting.File)
OutputCell.Value = aFile.Name
Set OutputCell = OutputCell.Offset(1, 0)
End Sub
Sub Main()
Const DirToSearch As String = "c:\test\", _
SearchToken As String = "microsoft"
Dim FileList As Scripting.Files, aFile As Scripting.File, _
OutputCell As Range, _
WDApp As Object, IStartedWord As Boolean
Initialize WDApp, IStartedWord, OutputCell
Set FileList = getFileList(DirToSearch)
For Each aFile In FileList
If TokenFound(aFile, SearchToken, WDApp) Then
AddThisFile OutputCell, aFile
End If
Next aFile
Shutdown WDApp, IStartedWord
'OutputCell.Parent.Activate
End Sub
