|
最近工作上需要整理一堆word和pdf文件,需要在这些文件中匹配关键字,然后把包含关键字的文件名和文件中包含关键字的句子顺序粘贴到一个新建的excel表的单元格中。由于pdf我还没安装,我尝试先写匹配WORD文件的部分,代码如下,但在strContent = objRange.Text这里只能返回关键字本身,没有找到能匹配出包含关键字句子的方法,在此求助,请大神帮忙看一下如何修改,谢谢。
Sub SearchWordFiles()
Dim objWord As Object
Dim objDoc As Object
Dim objRange As Object
Dim strFolderPath As String
Dim strSearchString As String
Dim strFileName As String
Dim strContent As String
Dim iRow As Integer
Dim objExcel As Object
Set objExcel = CreateObject("Excel.Application")
strFolderPath = "C:\Users\wang\Desktop\test"
strSearchString = [backcolor=rgba(245, 246, 249, 0.4)]InputBox("输入关键字", "提示")
objExcel.Visible = True
objExcel.Workbooks.Add
objExcel.Cells(1, 1).Value = "文件名"
objExcel.Cells(1, 2).Value = "内容"
iRow = 2
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
strFileName = Dir(strFolderPath & "*.docx")
Do While strFileName <> ""
Set objDoc = objWord.Documents.Open(strFolderPath & strFileName)
Set objRange = objDoc.Content
With objRange.Find
.Text = strSearchString
.Forward = True
.Wrap = 1 ' wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While objRange.Find.Execute
strContent = objRange.Text
objExcel.Cells(iRow, 1).Value = strFileName
objExcel.Cells(iRow, 2).Value = strContent
iRow = iRow + 1
Loop
objDoc.Close False
strFileName = Dir
Loop
objWord.Quit
Set objRange = Nothing
Set objDoc = Nothing
Set objWord = Nothing
Set objExcel = Nothing
MsgBox "搜索完成!"
End Sub
|
|