假设我们有多个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脚本代码实现:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | 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接口,相关代码实现如下:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | 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)供大家参考:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | 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运行上述代码以获得最佳体验,或者你可以下载 批量搜索Word或者Excel包含文字 (下载879) 。
刚下载下来用过了,无法查找.docx, txt文档。
这个是为Windows XP + Office 2003环境下Word设计的,不包含搜索文本文档,对于更高版本的Word(*.docx),你可以尝试将101~106行改为如下
对于TXT的搜索,建议使用FileSeek这款软件。
站长老大,你编程太牛了。帮我用vbs写个备份和恢复outlook2007配置文件的程序,好么?
抱歉,暂时没有这方面的考虑,也没有用过Outlook软件,不过我想这类软件应该带备份功能。