Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Search Text in Word or Excel Documents
'
' 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.