楼主
DJ_Soo |
之前写过不少获取目录的代码,但如果想以后再用的时候更方便的调用,当然是自定义代码最好,在此发布出来作为备份:- Option Explicit
- '主程序
- Sub Main()
- Dim arrList As Variant
- Dim lstPath As String '上次路径
- Dim mPath As String '选择的路径
- Dim Fs As Object
- Set Fs = CreateObject("scripting.filesystemobject")
- lstPath = Sheets("tmp").[A1]
- mPath = GetFolder("选择文件夹", lstPath)
- Sheets("tmp").[A1] = mPath
- arrList = Transpose(LlDirectory(mPath, Fs))
- [A:C].ClearContents
- [A1:C1] = Array("Type", "Size", "Path")
- [A2].Resize(UBound(arrList), 3) = arrList
- With [B:B]
- .TextToColumns , xlGeneralFormat
- .NumberFormat = "0 k\b"
- End With
- Set Fs = Nothing: End
- End Sub
- '获取对话框打开的文件所在地址,没有选择返回空,Title设置对话框的标题
- 'InitialFileName设置默认打开路径(可设置保留上次打开路径)
- Function GetFolder(Title As String, Optional InitialFileName As String) As String
- Dim Folder As Object
- Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
- With Folder
- .Title = Title
- .InitialFileName = InitialFileName
- .AllowMultiSelect = False '取消多选(没有针对多选写代码)
- If .Show = -1 Then GetFolder = .SelectedItems(1) & "\" '如果没有取消对话框,则获取地址
- End With
- Set Folder = Nothing
- End Function
- '获取下层目录Lower level directory
- Function LlDirectory(FolderPath As String, Fs As Object)
- Dim F As Object '获取当前folderpath的属性
- Dim fll As Object 'f的属性中subfolder可以获取所有子文件夹
- Dim fd As Object 'folder循环
- Dim file As Object 'file循环
- Static n As Long 'n获取文件的个数,static在递归时不初始化n为0
- Static arr() As String '存放文件路径'路径|size|属性(后缀)
-
- If FolderPath <> "" Then
- Set F = Fs.GetFolder(FolderPath & "\")
- Set fll = F.subfolders '.subfolder获取子文件夹,.files获取所有文件
- On Error Resume Next
- n = n + 1
- ReDim Preserve arr(1 To 3, 1 To n + F.Files.Count) As String
- With F '文件夹列表处理
- arr(3, n) = .Path & "\"
- arr(2, n) = .Size
- arr(1, n) = .Type
- End With
- For Each file In F.Files '文件列表处理
- n = n + 1
- arr(3, n) = file.Path
- arr(2, n) = file.Size
- arr(1, n) = file.Type
- Next file
- For Each fd In fll '递归,获取下层目录
- Call LlDirectory(fd.Path, Fs)
- Next fd
- LlDirectory = arr
- Else
- MsgBox "没有选择文件夹!", vbInformation + vbOKOnly, "Error!"
- End
- End If
- Set F = Nothing
- Set fll = Nothing
- Set fd = Nothing
- End Function
- '二维数组专用转置
- Function Transpose(arr As Variant)
- Dim arrTmp() As String
- Dim lstRo As Long
- Dim Ro As Long
- Dim lstCol As Long
- Dim Col As Long
- Dim lRo As Byte
- Dim lCol As Byte
- lstRo = UBound(arr, 1)
- lstCol = UBound(arr, 2)
- lRo = LBound(arr, 1)
- lCol = LBound(arr, 2)
- ReDim arrTmp(1 To lstCol - lCol + 1, 1 To lstRo - lRo + 1)
- For Ro = 1 To lstRo - lRo + 1
- For Col = 1 To lstCol - lCol + 1
- arrTmp(Col, Ro) = arr(Ro + lRo - 1, Col + lCol - 1)
- Next Col
- Next Ro
- Transpose = arrTmp
- End Function
说明在代码的注释中都有,不再赘述.上附件:
 Upload.zip
|