递归遍历文件，获取属性有没有更高效的办法

hmlstfqtl

用VBS的话，文件多的时候会很慢，有没有更好的办法？

1. Public iFileSys As Object
   
2. Sub 遍历文件夹()
   
3.     Cells.Delete                                               '清除表格所有数据
   
4.     Columns("B:B").NumberFormatLocal = "@"
   
5.     Columns("F:G").NumberFormatLocal = "yyyy-mm-dd hh:mm:ss"
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         If .Show = -1 Then
   
9.             iPath = .SelectedItems(1)
   
10.         End If
    
11.     End With
    
12.    
    
13.     If iPath = "False" Or Len(iPath) = 0 Then Exit Sub         '所选文件夹为空，结束脚本
    
14.    
    
15.     ReDim arr(1 To 7, 1 To 1)
    
16.     arr(1, 1) = "层级"
    
17.     arr(2, 1) = "文件名"
    
18.     arr(3, 1) = "完整路径（包含超链接）"
    
19.     arr(4, 1) = "类型"
    
20.     arr(5, 1) = "文件大小（KB）"
    
21.     arr(6, 1) = "创建时间"
    
22.     arr(7, 1) = "修改时间"
    
23.     Set iFileSys = CreateObject("Scripting.FileSystemObject")
    
24.     Call GetFolderFile(iPath, arr, 0)
    
25.     arr = TransposeArray(arr)
    
26.     ActiveSheet.Range("A1").Resize(UBound(arr), 7) = arr
    
27.    
    
28.     For i = 2 To UBound(arr)
    
29.         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 3), Address:=Cells(i, 3)
    
30.     Next
    
31.    
    
32.     ActiveSheet.Rows.AutoFit
    
33.     ActiveSheet.Columns.AutoFit
    
34.    
    
35.     MsgBox "Done."
    
36. End Sub
    
37. Private Sub GetFolderFile(ByVal nPath As String, arr As Variant, ByVal TreeNum As Long)
    
38.     Set iFolder = iFileSys.GetFolder(nPath)
    
39.     Set sFolder = iFolder.SubFolders
    
40.     Set iFile = iFolder.Files
    
41.    
    
42.     Call AddList(iFolder, arr, TreeNum)
    
43.    
    
44.     For Each gFile In iFile
    
45.         Call AddList(gFile, arr, TreeNum)
    
46.     Next
    
47.    
    
48.     '递归遍历所有子文件夹
    
49.     For Each nFolder In sFolder
    
50.         Call GetFolderFile(nFolder.Path, arr, TreeNum + 1)
    
51.     Next
    
52. End Sub
    
53. Private Sub AddList(ByVal obj As Object, arr As Variant, ByVal TreeNum As Long)
    
54.     ub = UBound(arr, 2) + 1
    
55.     ReDim Preserve arr(1 To 7, 1 To ub)
    
56.     arr(1, ub) = TreeNum                                       '层级
    
57.     arr(2, ub) = obj.Name                                      '文件名
    
58.     arr(3, ub) = obj.Path                                      '文件路径
    
59.     arr(4, ub) = obj.Type                                      '文件类型
    
60.     arr(5, ub) = Format(obj.Size / 1024, "#,##0.00")           '文件大小(KB)
    
61.     arr(6, ub) = Format(obj.DateCreated, "yyyy-mm-dd hh:mm:ss") '创建时间
    
62.     arr(7, ub) = Format(obj.DateLastModified, "yyyy-mm-dd hh:mm:ss")    '修改时间
    
63. End Sub
    
64. Function TransposeArray(arrA) As Variant
    
65.     Dim aRes()
    
66.     If IsArray(arrA) Then
    
67.         ReDim aRes(LBound(arrA, 2) To UBound(arrA, 2), LBound(arrA, 1) To UBound(arrA, 1))
    
68.         For i = LBound(arrA, 1) To UBound(arrA, 1)
    
69.             For j = LBound(arrA, 2) To UBound(arrA, 2)
    
70.                 aRes(j, i) = arrA(i, j)
    
71.             Next
    
72.         Next
    
73.         TransposeArray = aRes
    
74.     End If
    
75. End Function
    

复制代码

liulang0808

https://club.excelhome.net/thread-1613618-1-1.html
可以参考

smiletwo

做过类似的文档管理器，加了超链接要频繁读写单元格，基本难提高。

leolee82

高效的，建议去看看everything源码

zpy2

leolee82 发表于 2022-3-28 22:33
高效的，建议去看看everything源码

是不是官网上有的二次开发sdk吧

leolee82

zpy2 发表于 2022-3-29 08:01
是不是官网上有的二次开发sdk吧

Everything-SDK.zip (176.28 KB, 下载次数: 3)

2022-3-29 10:47 上传

点击文件名下载附件

刚去官网看了下，顺便下载了下来