获取文件系统目录

Dj_soo · 发表于 2012-5-22 13:32

本帖最后由爱疯于 2012-7-11 16:36 编辑

之前写过不少获取目录的代码,但如果想以后再用的时候更方便的调用,当然是自定义代码最好,在此发布出来作为备份:

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 (26.95 KB, 下载次数: 157)

cuirencui · 发表于 2012-5-26 05:29

自定义函数之获取目录先下了

许诺寒2008 · 发表于 2012-5-31 21:19

谢谢楼主！！学习一下！

hjcexecl · 发表于 2012-6-11 22:35

谢谢楼主！！学习一下！

xdwy456 · 发表于 2012-6-13 21:30

3dmax456789 · 发表于 2012-9-25 12:32

谢谢分享！学习了！

joyark · 发表于 2012-12-10 23:51

谢谢分享！学习了！

匿名 *发表于 2015-1-28 17:42* · 发表于 2015-1-28 17:42

谢谢,试试

		自动登录	找回密码
密码			注册

[分享] 获取文件系统目录