Sub GetWordText改进()
Dim Wb As Workbook
Dim Sht As Worksheet
Dim Rng As Range Dim wdApp As Object
Dim wdDoc As Object
Dim FilePaths
Dim FilePath
Dim Arr(1 To 10000, 1 To 6)
Dim n As Long
Dim Index As Long Dim Regex As Object
Dim Mh As Object
Pattern = ".*?[：:](\S*)\s*?.*?[：:](\S*)\s*?" & _
".*?[：:](\S*)\s*?.*?[：:](\S*)\s*?" & _
".*?[：:](\S*)\s*?.*?[：:](\S*)"
Set Regex = CreateObject("VBScript.RegExp")
With Regex
.Global = True
.Pattern = Pattern
End With Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("汇总")
With Sht
.UsedRange.Offset(1).ClearContents
End With
FilePaths = FsoGetFiles(Wb.Path & "\", "*.doc*")
If FilePaths(1) = "None" Then Exit Sub
Index = 0 Set wdApp = CreateObject("Word.Application")
For n = LBound(FilePaths) To UBound(FilePaths) 'On Error Resume Next
Set wdDoc = wdApp.documents.Open(FilePaths(n))
If wdDoc Is Nothing Then
GoTo NextDocument
Else
If wdDoc.Tables.Count > 0 Then
Debug.Print "含表格："; FilePaths(n)
Index = Index + 1
For j = 1 To 6
Text = wdDoc.Tables(1).cell(1, j).Range.Text
Text = Replace(Text, Chr(10), "")
Text = Replace(Text, Chr(7), "")
Text = Replace(Text, Chr(13), "")
Arr(Index, j) = "'" & Text
Debug.Print Index; " "; Arr(Index, j)
Next j
Else
Debug.Print "纯文本："; FilePaths(n)
If Regex.test(wdDoc.Content.Text) Then
Set Mh = Regex.Execute(wdDoc.Content.Text)
Index = Index + 1
For j = 0 To Mh.Item(0).submatches.Count - 1
Arr(Index, j + 1) = "'" & Mh.Item(0).submatches(j)
Debug.Print Index; " "; Arr(Index, j + 1)
Next j
End If
End If
End If
wdDoc.Close False
NextDocument:
On Error GoTo 0
Next n wdApp.Quit With Sht
Set Rng = .Range("A2")
Set Rng = Rng.Resize(UBound(Arr), UBound(Arr, 2))
Rng.Value = Arr
End With Set Wb = Nothing
Set Sht = Nothing
Set Rng = Nothing
Set wdApp = Nothing
Set wdDoc = Nothing End Sub
Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
Dim Arr() As String
Dim FSO As Object
Dim ThisFolder As Object
Dim OneFile As Object
ReDim Arr(1 To 1)
Arr(1) = "None"
Dim Index As Long
Index = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo ErrorExit
Set ThisFolder = FSO.getfolder(FolderPath)
If Err.Number <> 0 Then Exit Function
For Each OneFile In ThisFolder.Files
If OneFile.Name Like Pattern Then
If Len(ComplementPattern) > 0 Then
If Not OneFile.Name Like ComplementPattern Then
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path '& OneFile.Name
End If
Else
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path '& OneFile.Name
End If
End If
Next OneFile
ErrorExit:
FsoGetFiles = Arr
Erase Arr
Set FSO = Nothing
Set ThisFolder = Nothing
Set OneFile = Nothing
End Function