ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 7043|回复: 16

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2012-5-17 12:59 | 显示全部楼层 |阅读模式
本帖最后由 a20089668 于 2012-7-30 17:41 编辑

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

等待大侠的无私帮助,感谢!!

获取文件夹名称及属性.rar

11.02 KB, 下载次数: 156

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-5-19 19:56 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-5-19 22:29 | 显示全部楼层
  1. '引用Microsoft Scripting Runtime
  2. Private Sub CommandButton1_Click()
  3.     Dim Fso As New FileSystemObject
  4.     Dim MyFolder As Folder
  5.     Dim Sub_Folder As Folder
  6.     Dim p As String
  7.     Dim m As Long
  8.     Dim arr()
  9.     p = "C:"'以C盘为例
  10.     Set MyFolder = Fso.GetFolder(p)
  11.     For Each Sub_Folder In MyFolder.SubFolders
  12.         m = m + 1
  13.         ReDim Preserve arr(1 To 6, 1 To m)
  14.         arr(1, m) = m
  15.         arr(2, m) = Sub_Folder.Name
  16.         arr(3, m) = FormatNumber(MyFolder.Size / 1024, 0)
  17.         arr(4, m) = Sub_Folder.DateCreated
  18.         arr(5, m) = Sub_Folder.Files.Count
  19.         arr(6, m) = Sub_Folder.SubFolders.Count
  20.     Next
  21.     Range("a2").Resize(m, 6) = WorksheetFunction.Transpose(arr)
  22. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2012-5-19 22:30 | 显示全部楼层
请看附件
获取文件夹名称及属性.rar (17.96 KB, 下载次数: 250)

TA的精华主题

TA的得分主题

 楼主| 发表于 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

TA的精华主题

TA的得分主题

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

估计是操作系统惹的祸,我的win7也是这样,只有它不控制的C盘可以
加一个错误处理,忽略查不到的属性吧:
  1. '引用Microsoft Scripting Runtime
  2. Private Sub CommandButton1_Click()
  3.     Dim Fso As New FileSystemObject
  4.     Dim MyFolder As Folder
  5.     Dim Sub_Folder As Folder
  6.     Dim p As String
  7.     Dim m As Long
  8.     Dim arr()
  9.     p = "f:"
  10.     On Error Resume Next
  11.     Set MyFolder = Fso.GetFolder(p)
  12.     For Each Sub_Folder In MyFolder.SubFolders
  13.         m = m + 1
  14.         ReDim Preserve arr(1 To 6, 1 To m)
  15.         arr(1, m) = m
  16.         arr(2, m) = Sub_Folder.Name
  17.         arr(3, m) = FormatNumber(MyFolder.Size / 1024, 0)
  18.         arr(4, m) = Sub_Folder.DateCreated
  19.         arr(5, m) = Sub_Folder.Files.Count
  20.         arr(6, m) = Sub_Folder.SubFolders.Count
  21.     Next
  22.     Range("a2").Resize(m, 6) = WorksheetFunction.Transpose(arr)
  23. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 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

TA的精华主题

TA的得分主题

发表于 2012-5-22 20:11 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-5-22 23:01 | 显示全部楼层
有些文件夹本身就无法访问,比如System Volume Information,什么原因造成的不清楚,如图
未命名.JPG

TA的精华主题

TA的得分主题

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

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

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

十分感谢各位的帮助。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-4-20 14:24 , Processed in 0.095311 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表