如何用VBA获取某分区下的全部文件夹的名称及属性？

a20089668 · 发表于 2012-5-17 12:59

本帖最后由 a20089668 于 2012-7-30 17:41 编辑

就如：右键点击文件夹一样，查看到文件夹的属性。
不过我该分区的文件夹比较多，势必难一一右键点击查询并手工输入这个工作表内。
VBA要实现的功能：
点击“按钮”，弹出对话框，等用户选择了某个磁盘分区，按“确定”后，程序自动读取该分区的所有文件夹（该文件夹内的子文件夹不用理会）的名称、大小、创建时间写入表格内。

等待大侠的无私帮助，感谢！！

a20089668 · 发表于 2012-5-19 19:56

怎么没人回复的？哪位大侠帮帮忙？

zhaogang1960 · 发表于 2012-5-19 22:29

'引用Microsoft Scripting Runtime
Private Sub CommandButton1_Click()
Dim Fso As New FileSystemObject
Dim MyFolder As Folder
Dim Sub_Folder As Folder
Dim p As String
Dim m As Long
Dim arr()
p = "C:"'以C盘为例
Set MyFolder = Fso.GetFolder(p)
For Each Sub_Folder In MyFolder.SubFolders
m = m + 1
ReDim Preserve arr(1 To 6, 1 To m)
arr(1, m) = m
arr(2, m) = Sub_Folder.Name
arr(3, m) = FormatNumber(MyFolder.Size / 1024, 0)
arr(4, m) = Sub_Folder.DateCreated
arr(5, m) = Sub_Folder.Files.Count
arr(6, m) = Sub_Folder.SubFolders.Count
Next
Range("a2").Resize(m, 6) = WorksheetFunction.Transpose(arr)
End Sub

复制代码

zhaogang1960 · 发表于 2012-5-19 22:30

请看附件

获取文件夹名称及属性.rar (17.96 KB, 下载次数: 269)

a20089668 · 发表于 2012-5-22 18:39

本帖最后由 a20089668 于 2012-5-22 18:43 编辑

zhaogang1960 发表于 2012-5-19 22:30
请看附件

尊敬的版主，我下载附件后运行提示  运行时错误‘70’：拒绝的权限。
我的运行环境是XP+office2010，屏蔽掉  运行时提示错误的3句代码，能正常，但是得不到了该分区下的文件夹大小、子文件夹的数量以及文件的数量。

'引用Microsoft Scripting Runtime    我查看过VBA窗口工具栏下已经引用了。
Private Sub CommandButton1_Click()
Dim Fso As New FileSystemObject
Dim MyFolder As Folder
Dim Sub_Folder As Folder
Dim p As String
Dim m As Long
Dim arr()
p = "g:\"
Set MyFolder = Fso.GetFolder(p)
For Each Sub_Folder In MyFolder.SubFolders
      m = m + 1
      ReDim Preserve arr(1 To 6, 1 To m)
      arr(1, m) = m
      arr(2, m) = Sub_Folder.Name
      'arr(3, m) = FormatNumber(MyFolder.Size / 1024, 0) 运行时错误‘70’：拒绝的权限。
      arr(4, m) = Sub_Folder.DateCreated
      'arr(5, m) = Sub_Folder.Files.Count 运行时错误‘70’：拒绝的权限。
      'arr(6, m) = Sub_Folder.SubFolders.Count 运行时错误‘70’：拒绝的权限。
Next
Range("a2").Resize(m, 6) = WorksheetFunction.Transpose(arr)
End Sub

zhaogang1960 · 发表于 2012-5-22 19:47

a20089668 发表于 2012-5-22 18:39
尊敬的版主，我下载附件后运行提示运行时错误‘70’：拒绝的权限。
我的运行环境是XP+office2010，屏蔽 ...

估计是操作系统惹的祸，我的win7也是这样，只有它不控制的C盘可以
加一个错误处理，忽略查不到的属性吧：

'引用Microsoft Scripting Runtime
Private Sub CommandButton1_Click()
Dim Fso As New FileSystemObject
Dim MyFolder As Folder
Dim Sub_Folder As Folder
Dim p As String
Dim m As Long
Dim arr()
p = "f:"
On Error Resume Next
Set MyFolder = Fso.GetFolder(p)
For Each Sub_Folder In MyFolder.SubFolders
m = m + 1
ReDim Preserve arr(1 To 6, 1 To m)
arr(1, m) = m
arr(2, m) = Sub_Folder.Name
arr(3, m) = FormatNumber(MyFolder.Size / 1024, 0)
arr(4, m) = Sub_Folder.DateCreated
arr(5, m) = Sub_Folder.Files.Count
arr(6, m) = Sub_Folder.SubFolders.Count
Next
Range("a2").Resize(m, 6) = WorksheetFunction.Transpose(arr)
End Sub

复制代码

汪淑萍 · 发表于 2012-5-22 20:10

Sub 获取文件夹中所有文件的信息() '会忽略子目录
On Error Resume Next
Dim arr(), 目录 As String, mj As String, Item As Integer
目录 = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0).Self.Path
Range("A1:E1") = Array("序号", "文件名称", "文件大小", "创建时间", "最后修改时间")
Dim wj As String
wj = Dir(目录 & "\*.*")
Do
      Item = Item + 1
   ReDim Preserve arr(1 To 5, 1 To Item) '重置数组并保留值
      arr(1, Item) = Item  '编号
      arr(2, Item) = wj  '文件名
      arr(3, Item) = Round(FileLen(目录 & "\" & wj) / 1024, 2) & "KB" '文件大小
      arr(4, Item) = CreateObject("scripting.filesystemobject").GetFile(目录 & "\" & wj).DateCreated '创建时间，只能用FSO对象来获取
      arr(5, Item) = FileDateTime(目录 & "\" & wj)  '最后修改时间
      wj = Dir
Loop Until Len(wj) = 0 '循环，直到最后一个文件（和While...Wend语句一样）
[a2].Resize(UBound(arr, 2), 5) = WorksheetFunction.Transpose(arr)  '将数组转置后导入工作表
Columns("A:E").EntireColumn.AutoFit  '让单元格自动调整列宽
End Sub

汪淑萍 · 发表于 2012-5-22 20:11

老罗写的'

wpxxsyzx · 发表于 2012-5-22 23:01

有些文件夹本身就无法访问，比如System Volume Information，什么原因造成的不清楚，如图

a20089668 · 发表于 2012-5-23 09:36

汪淑萍发表于 2012-5-22 20:10
Sub 获取文件夹中所有文件的信息() '会忽略子目录
On Error Resume Next
Dim arr(), 目录 As Str ...

该段代码实现读取所选择文件夹下的文件信息，并忽略子文件夹。对我来说也很有用。

版主的代码更加符合我现在的需要，只是读取不到文件夹的大小。

十分感谢各位的帮助。

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

[已解决] 如何用VBA获取某分区下的全部文件夹的名称及属性？

最新热点 /1