楼主
chenlifeng |
通过对话框指定盘符，再把该盘符下面的word文件中的文件全名、文件创建时间，全部列成清单，见下面代码。
共两种方法，其中第一种用到了正则，第二种是用到了fso。通过反复测试1万3千个word文件，发现：
第一种方法只用4秒，第二种用5秒。故向大家提一个疑问：调用fso时，会比纯粹的进行文本处理，要慢一点？谢谢！
另外，如果在后面再加一个word的属性，如公司名称BuiltinDocumentProperties.Item(21)，则速度明显慢下来了，保守估计都得花十多分钟。
期望有新解释，能够提高速度到一两分钟。- Sub test1()
- ''方法一：
- Dim 起始时间
- 起始时间 = Timer
- Dim FN$, FN2$, Str$, Arr, Arrt, N&, I&, Match
- FN = ThisWorkbook.Path & "\list.txt"
- FN2 = ThisWorkbook.Path & "\list2.txt"
- With Application.FileDialog(msoFileDialogFolderPicker) '打开文件夹选取菜单
- If .Show = -1 Then '如果正常显示，则调用命令行命令取得文件夹下的目录列表并存入列表文件中
- CreateObject("wscript.shell").Run Environ("comspec") & " /c dir /s/b """ & .SelectedItems(1) & "\*.doc?"">""" & FN & """", 0, 1
- If Dir(FN) <> "" Then
- On Error Resume Next
- With CreateObject("scripting.filesystemobject").OpenTextFile(FN)
- Str = .ReadAll
- .Close
- End With
- On Error GoTo 0
- If Str <> "" Then
- Arr = Split(Str, vbCrLf)
- Str = ""
- CreateObject("wscript.shell").Run Environ("comspec") & " /c dir /s/tc/4 """ & .SelectedItems(1) & "\*.doc?"">""" & FN2 & """", 0, 1
- On Error Resume Next
- With CreateObject("scripting.filesystemobject").OpenTextFile(FN2)
- Str = .ReadAll
- .Close
- End With
- ' MsgBox Str
- On Error GoTo 0
- If Str <> "" Then
- With CreateObject("vbscript.regexp")
- .Global = True
- .MultiLine = True
- .Pattern = "(^|[\r\n])(\d{4}\-\d{2}\-\d{2})"
- If .test(Str) Then
- ReDim Arrt(LBound(Arr) To UBound(Arr))
- I = LBound(Arr)
- For Each Match In .Execute(Str)
- Arrt(I) = Arr(I) & "\" & Match.submatches(1)
- I = I + 1
- If I > UBound(Arr) Then Exit For
- Next Match
- Open FN2 For Output As #1
- Print #1, Join(Arrt, vbCrLf)
- Close #1
- End If
- End With
- End If
- End If
- End If
- End If
- End With
- MsgBox Format((Timer - 起始时间) / 24 / 60 / 60, "hh:mm:ss")
- End Sub
- Sub 指定文件到显示清单()
- ''方法二：
- On Error Resume Next
- Dim Arr, Arr2, I As Long, J As Long, Ob As Object, Str As String, RQ As Date
- Dim 起始时间
- 起始时间 = Timer
-
- With Application.FileDialog(msoFileDialogFolderPicker)
- If .Show = -1 Then
- CreateObject("wscript.shell").Run Environ("comspec") & " /c dir /s/b """ & .SelectedItems(1) & "\*.doc?"">""" & ThisWorkbook.Path & "\789.txt""", 0, 1 '利用wsh对象运行命令行dir命令获取选定文件夹下的全部excel工作簿清单,利用输出重定向输出到列表文件中并等待命令执行完成后返回程序继续执行
- End If
- End With
- With CreateObject("scripting.filesystemobject").OpenTextFile(ThisWorkbook.Path & "\789.txt")
- Str = .ReadAll
- .Close
- End With
- Arr = Split(Str, vbCrLf)
- I = UBound(Arr)
- ReDim Arr2(1 To I)
- Application.ScreenUpdating = False
- With CreateObject("Scripting.FileSystemObject")
- For J = 0 To I
- ' If Format(.GetFile(Arr(j)).DateCreated, "yyyy-mm-dd") - Format(.GetFile(Arr(j)).DateLastModified, "yyyy-mm-dd") < 0 Then
- RQ = Format(.GetFile(Arr(J)).DateCreated, "yyyy-mm-dd")
- ' Else
- ' RQ = Format(.GetFile(Arr(j)).DateLastModified, "yyyy-mm-dd")
- ' End If
- Arr2(J + 1) = Arr(J) & "\" & RQ '& "\" & Str
- Next J
- End With
- Application.ScreenUpdating = False
- Open ThisWorkbook.Path & "\789.txt" For Output As #1
- Print #1, Join(Arr2, vbCrLf)
- Close #1
- MsgBox Format((Timer - 起始时间) / 24 / 60 / 60, "hh:mm:ss")
- End Sub
|
看看