Search Text in Word or Excel Documents

search.vbs

'
' Author: wangye
' For more information please visit
'   http://wangye.org/blog/archives/591/
'

Option Explicit

Dim hasMatchCase
Dim hasRecursion
Dim includeDocuments
Dim includeWorkbooks
Dim stopIfFound
Dim lookupType

Dim SearchLists

Class DocumentsFinder
    
    Private vbaObject
    Private Application
    
    Private Sub Class_Initialize()
        Set vbaObject = WSH.CreateObject("Word.Application")
            vbaObject.Visible = False
    End Sub
    
    Private Sub Class_Terminate()
            vbaObject.Visible = True
            vbaObject.Quit
        Set vbaObject = Nothing
    End Sub
    
    Private Function SearchStringInSingleDocument(str, doc)
        Dim Selection
        Set Selection = vbaObject.Selection
            Selection.WholeStory
            With Selection.Find
                .ClearFormatting
                .MatchWholeWord = False
                .MatchCase = False
                SearchStringInSingleDocument =.Execute(str)
            End With
        Set Selection = Nothing
    End Function
    
    Public Function isTextExists(str, filename)
        On Error Resume Next
        Dim doc
        Set doc = vbaObject.Documents.Open(filename)
            isTextExists = SearchStringInSingleDocument(str, doc)
            doc.Close
        Set doc = Nothing
        If Err Then Err.Clear
    End Function
End Class

Class WorkbooksFinder
    
    Private vbaObject
    Private Application
    
    Private Sub Class_Initialize()
        Set vbaObject = WSH.CreateObject("Excel.Application")
            vbaObject.Visible = False
    End Sub
    
    Private Sub Class_Terminate()
            vbaObject.Visible = True
            vbaObject.Quit
        Set vbaObject = Nothing
    End Sub
    
    Private Function SearchStringInSingleSheet(str, sheet)
        ' See http://support.microsoft.com/kb/108892
        Dim RangeObj
        Set RangeObj = sheet.Cells.Find(str)
            SearchStringInSingleSheet = CBool(Not (RangeObj Is Nothing))
        Set RangeObj = Nothing
    End Function
    
    Public Function isTextExists(str, filename)
        On Error Resume Next
        isTextExists = False
        Dim Workbooks,Worksheets
        Set Workbooks = vbaObject.Workbooks.Open(filename)

        For Each Worksheets In Workbooks.Worksheets
            isTextExists = SearchStringInSingleSheet(str, Worksheets)
            If isTextExists Then Exit For
        Next

        Workbooks.Close
        Set Workbooks = Nothing
        If Err Then Err.Clear
    End Function
End Class

Function Dispatch(self, fso, file, params)
    Dispatch = False
    Const DOCUMENTS_FINDER = 0
    Const WORKBOOKS_FINDER = 1
    Const SEARCH_LIST_OBJECT = 2
    Const FOUND_LIST_OBJECT = 3
    
    Dim ObjectIndex : ObjectIndex = -1
    Select Case UCase(fso.GetExtensionName(file.Name))
        Case "DOC"
            ObjectIndex = DOCUMENTS_FINDER
        Case "XLS"
            ObjectIndex = WORKBOOKS_FINDER
    End Select
    
    If ObjectIndex < 0 Then Exit Function
    
    If Not (params(ObjectIndex) Is Nothing) Then
        If params(ObjectIndex) _
            .isTextExists(params(SEARCH_LIST_OBJECT), _
                        fso.GetAbsolutePathName(file)) Then
            ' 将找到文件对象添加到找到列表中
            'FoundLists.Add file.Name, fso.GetAbsolutePathName(file)
            WSH.Echo file.Name & " > " & fso.GetAbsolutePathName(file)
            ' 找到即停止
            If stopIfFound Then Dispatch = True
        End If
    End If
End Function

Sub Lookup(startFolder)
    Dim params(3)
    
    Set params(0) = Nothing
    Set params(1) = Nothing
    
    If includeDocuments Then
        Set params(0) = New DocumentsFinder
    End If
    
    If includeWorkbooks Then
        Set params(1) = New WorkbooksFinder
    End If
    
    params(2) = SearchLists
    
    'Set params(3) = FoundLists
    
    Dim fp
    Set fp = New FileOperation
        fp.EnumFiles startFolder, "Dispatch", hasRecursion, params
    Set fp = Nothing
    
    'Set params(3) = Nothing
    Set params(2) = Nothing
    Set params(1) = Nothing
    Set params(0) = Nothing
End Sub

Sub VBMain()
    hasMatchCase = False
    includeDocuments = True
    includeWorkbooks = True
    hasRecursion = True
    SearchLists = ""
    
    Dim fso,strFolderName
    Set fso = WSH.CreateObject("Scripting.FileSystemObject")
    strFolderName = GetOpenDirectory("选择要搜索的目录")
    If strFolderName="" Or (Not fso.FolderExists(strFolderName)) Then
        WSH.Echo "未选择查找目录或者选择无效"
    Else

        Do
          SearchLists = InputBox("输入要查找的文本字符串",_
            "WORD EXCEL 搜索工具", "")
          If SearchLists="" Then
            If MsgBox("需要填入要搜索的文本，重新填写吗？",_
            vbOKCancel, "") = VbCancel Then
              Exit Sub
            End If
          End If
        Loop Until SearchLists<>""
        Lookup strFolderName

        WSH.Echo "搜索完毕！"
    End If
    Set fso = Nothing
End Sub

Function GetOpenDirectory(title)
    Const SHELL_MY_COMPUTER = &H11
    Const SHELL_WINDOW_HANDLE = 0
    Const SHELL_OPTIONS = 0
    Dim ShlApp,ShlFdr,ShlFdrItem
 
    Set ShlApp = WSH.CreateObject("Shell.Application")
    Set ShlFdr = ShlApp.Namespace(SHELL_MY_COMPUTER)
    Set ShlFdrItem = ShlFdr.Self
    GetOpenDirectory = ShlFdrItem.Path
    Set ShlFdrItem = Nothing
    Set ShlFdr = Nothing
 
    Set ShlFdr = ShlApp.BrowseForFolder _
                (SHELL_WINDOW_HANDLE, _
                title, _
                SHELL_OPTIONS, _
                GetOpenDirectory)
    If ShlFdr Is Nothing Then
        GetOpenDirectory = ""
    Else
        Set ShlFdrItem = ShlFdr.Self
        GetOpenDirectory = ShlFdrItem.Path
        Set ShlFdrItem = Nothing
    End If
    Set ShlApp = Nothing
End Function

Class FileOperation
 
    Private AxFile   
    Private Sub Class_Initialize()
        Set AxFile = WSH.CreateObject("Scripting.FileSystemObject")
    End Sub
 
    Private Sub Class_Terminate()
        Set AxFile = Nothing
    End Sub
 
    Private Function GetSubFolders(strFolder)
        If AxFile.FolderExists(strFolder) Then
            Dim oFolders
            Set oFolders = AxFile.GetFolder(strFolder)
            Set GetSubFolders = oFolders.SubFolders
            Set oFolders = Nothing
        Else
            Set GetSubFolders = Nothing
        End If
    End Function
 
    Private Function GetSubFiles(strFolder)
        If AxFile.FolderExists(strFolder) Then
            Dim oFolders
            Set oFolders = AxFile.GetFolder(strFolder)
            Set GetSubFiles = oFolders.Files
            Set oFolders = Nothing
        Else
            Set GetSubFiles = Null
        End If
    End Function
 
    Public Function EnumFiles(strFolder, fCallBackName, Recursion, Param)
        EnumFiles = True
        If Not AxFile.FolderExists(strFolder) Then
            EnumFiles = False
            Exit Function
        End If
 
        Dim fCallBack
        Dim SubFiles, SubFile, SubFolders, SubFolder
 
        Set fCallBack = GetRef(fCallBackName)
        
        If TypeName(strFolder) = "Folder" Then
            Set SubFiles = strFolder.Files
        Else
            Set SubFiles = GetSubFiles(strFolder)
        End If
        For Each SubFile In SubFiles
            If fCallBack(Me, AxFile, SubFile, Param) Then Exit For
        Next
        Set SubFiles = Nothing
 
        If Recursion Then
        Set SubFolders = GetSubFolders(strFolder)
            For Each SubFolder In SubFolders
                Call EnumFiles(AxFile.GetAbsolutePathName(SubFolder), _
                                  fCallBackName, Recursion, Param)
            Next
            Set SubFolders = Nothing
        End If
        
        Set fCallBack = Nothing
    End Function
 
    Public Function EnumFolders(strFolder, fCallBackName, Recursion, Param)
        EnumFolders = True
        If Not AxFile.FolderExists(strFolder) Then
            EnumFolders = False
            Exit Function
        End If
        
        Dim fCallBack
        Dim SubFolders, SubFolder, ChildFolders, ChildFolder
 
        Set fCallBack = GetRef(fCallBackName)
 
        Set SubFolders = GetSubFolders(strFolder)
            For Each SubFolder In SubFolders
                If fCallBack(Me, AxFile, SubFolder, Param) Then Exit For
                
                If Recursion Then
                    Set ChildFolders = SubFolder.SubFolders
                    For Each ChildFolder In ChildFolders
                        If fCallBack(Me, AxFile, ChildFolder, Param) Then Exit For
                        Call EnumFolders(AxFile.GetAbsolutePathName(ChildFolder), _
                                  fCallBackName, Recursion, Param)
                    Next
                    Set ChildFolders = Nothing
                End If
            Next
        Set SubFolders = Nothing

        
        Set fCallBack = Nothing
    End Function
End Class

VBMain
WSH.Quit