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

假设我们有多个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"]。