中财网地名来历怎么写:VBA实例:Word文档内容搜索器，文件遍历，当前位置下子文件夹遍历(by daode12...
来源：百度文库 编辑：中财网 时间：2024/05/09 14:33:23
'''Word文档内容搜索器，文件遍历，当前位置下子文件夹遍历
'''输出于Excel/Sheet2中
'''存在的用"***"表示，不存在的用"---"表示。
'''要搜索的字符在openWord中：xStr ="???"中定义。
'''本VBA用于Excel,可粘贴于模块中，再运行宏。
'''------by daode1212 , 2010-10-20
Dim nFile As Integer
Sub 遍历子文件在DOC中搜索字符()
'''DOC搜索主程序入口:
nFile = 0
way = ThisWorkbook.path
getAllFolder CStr(way)
End Sub
Sub getAllFolder(path)
'''遍历文件夹:
Set fso = CreateObject("Scripting.FileSystemObject")
Set objfolder = fso.GetFolder(path)
Set objSubFolders = objfolder.SubFolders
Set objfolder = Nothing
getAllFile path
For Each objSubFolder In objSubFolders
nowPath = CStr(path & "\" & objSubFolder.Name)
getAllFolder nowPath
'''getAllFile nowPath
Next
Set fso = Nothing
End Sub
Sub getAllFile(fold)
'''遍历文件,输出路径与文件名:
Set fso = CreateObject("Scripting.FileSystemObject")
Set objfiles = fso.GetFolder(fold)
For Each objfile In objfiles.Files
nowFile = objfile.Name
If LCase(Right(nowFile, 4)) = ".doc" Then
nFile = nFile + 1 '文件个数，写入Sheet2中的行标；
Sheet2.Cells(nFile, 2) = fold
Sheet2.Cells(nFile, 3) = nowFile
curPF = fold & "\" & nowFile
openWord curPF, nFile
End If
Next
Set objfiles = Nothing
Set fso = Nothing
End Sub
Sub openWord(curPF, nFile)
'''搜索字符串:
xStr = "防雪防冻"
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
Set wrdDoc = wrdApp.Documents.Open(curPF)
strText = wrdDoc.Range.Text() '读取全文；
If InStr(strText, xStr) Then
Sheet2.Cells(nFile, 1) = "***" '找到的文件；
Else
Sheet2.Cells(nFile, 1) = "---" '未找到的文件；
End If
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
'''课题之一：将本程序修改为文本的替换；
'''课题之二：将本程序修改为特有文本的剥取；