VBA/VBScript批量搜索多个Word或者Excel指定的包含文字

提醒：本页面将不再更新、维护或者支持，文章、评论所叙述内容存在时效性，涉及技术细节或者软件使用方面不保证能够完全有效可操作，请谨慎参考！

假设我们有多个Word或者Excel文件，现在我们要从这些文件中搜索特定的关键字，比较笨的办法就是一个一个打开，然后“编辑 - 查找”，文件少还好办，如果文件比较多的话，那么打开这么多文件也累得我们够呛。

下面我讲解一个利用VBScript自动批量搜索特定文字的办法，首先还是上面的算法，只不过将人工一个一个打开换成计算机自动打开。实际上这里主要是枚举文件，然后在利用ActiveX控件调用Word.Application或者Excel.Application内部的查找方法来实现相关功能。

对于一份简单的Word文档，基本的查找VBA可以像下面这样实现：

Dim hasFound ' 定义是否找到
Selection.WholeStory
With Selection.Find
    .ClearFormatting
    .MatchWholeWord = False
    .MatchCase = False
    hasFound = .Execute("要查找的文字")
End With

转化为VBScript代码也很容易，多个创建Word.Application并打开Word文件的过程。

下面定义FileFinder接口，当然VBS没有接口的概念，我们只是象征式的说明下：

Interface FileFinder
    Function isTextExists(search, filename)
    End Function
End Interface

只需要实现一个方法接口，那就是isTextExists，判断要搜索的文本是否存在于指定的文件中。下面给出关于Word查找的VBS脚本代码实现：

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

其中调用了Documents.Open打开一个Word文档，然后再通过SearchStringInSingleDocument方法来搜索指定文档的文字，这个方法就是刚才讲解的VBA宏的实现。

关于Excel的查找和Word稍有不同，大家知道一份Excel文件算是工作簿（WorkBook），工作簿里面有多个工作表（WorkSheet），比如Sheet1、Sheet2等，所以我们需要搜索当前工作簿下的所有工作表，然后通过调用Sheet.Cells.Find方式来检索文字是否存在，关于Excel的Find查找文字的方式可以参考微软的《Cells.Find 返回错误时找到不匹配》，基本VBA代码如下：

Dim hasFound ' 定义是否找到
Dim RangeObj
For Each Sheet In Workbooks.Worksheets
    Set RangeObj = Sheet.Cells.Find(str)
    hasFound = CBool(Not (RangeObj Is Nothing))
    Set RangeObj = Nothing
    If hasFound Then Exit For
Next

基于刚才叙述的FileFinder接口，相关代码实现如下：

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

好了，关于Word和Excel的文字查找的实现代码都有了，接下来是万事俱备只欠东风了，东风就是文件枚举的代码实现。这点我在前面的文章《利用Scripting.FileSystemObject组件来枚举文件》已经介绍过方法了，大家可以移步围观下。

基于上面的工作，下面我实现了一个简单的批量搜索多个Word或者Excel指定的文字的小程序（ github gist ）供大家参考：

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
            ' 将找到文件对象输出
            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

建议采用CScript运行上述代码以获得最佳体验，或者你可以下载[download id="1130"]。

4 thoughts on this post

sinhoi Says:

November 16, 2012 09:03:32

刚下载下来用过了，无法查找.docx, txt文档。
1. 王晔 Says:
  
  November 16, 2012 20:56:00
  这个是为Windows XP + Office 2003环境下Word设计的，不包含搜索文本文档，对于更高版本的Word(*.docx)，你可以尝试将101~106行改为如下
```
Select Case UCase(fso.GetExtensionName(file.Name))
    Case "DOC", "DOCX"
        ObjectIndex = DOCUMENTS_FINDER
    Case "XLS"
        ObjectIndex = WORKBOOKS_FINDER
End Select
```
  对于TXT的搜索，建议使用FileSeek这款软件。
sinhoi Says:

November 16, 2012 09:15:50

站长老大，你编程太牛了。帮我用vbs写个备份和恢复outlook2007配置文件的程序，好么？
1. 王晔 Says:
  
  November 16, 2012 20:57:24
  
  抱歉，暂时没有这方面的考虑，也没有用过Outlook软件，不过我想这类软件应该带备份功能。

Comments are closed. / 此内容评论功能已经关闭。