获取指定文件夹及其子文件夹下所有文件信息、并做成超链接

ivccav · 发表于 2018-1-13 13:10

shi7361 发表于 2018-1-13 10:57
用代码也行吧？参照文件在前一列出现了，用代码读取一下文件不可以么？我是这么想的

自定义一个函数:=getdate(B8,1)
1表示创建日期，2表示修改日期

Function getdate(rng As Range, dt As Integer)
fn = rng.Hyperlinks(1).Address
With CreateObject("scripting.filesystemobject")
      Set f = .GetFile(fn)
      If dt = 1 Then
         getdate = Format(f.DateCreated, "yyyy/mm/dd hh:mm:ss")
      Else
         getdate = Format(f.DateLastModified, "yyyy/mm/dd hh:mm:ss")
      End If
End With
End Function

ivccav · 发表于 2018-1-13 13:24

lihuan_ 发表于 2018-1-13 12:06
楼主，问个问题怎么把文件所在的文件夹名称提取出来然后做个路径？做在后面路径后G列呢？

Cells(Rows.C ...

Cells(Rows.Count, 7).End(3).Offset(1)=Left(f.Path, InStrRev(f.Path, "\", -1, 1))

ivccav · 发表于 2018-1-13 14:07

shi7361 发表于 2018-1-13 10:54
如果我的单元格已经通过公式插入了超链接，如何在后面的单元格查找到超链接文件的创建和更新时间？谢谢

已看到你的问题，跟你在这里描述的不一样。已按你的要求写好代码，在附件中。

新建文件夹.zip (22.54 KB, 下载次数: 196)

Sub getproperty()
Dim r&, c As Range
r = Range("a" & Rows.Count).End(3).Row
For Each c In Range("a2:a" & r)
      With CreateObject("scripting.filesystemobject")
         If c.Hyperlinks.Count Then
            Set f = .GetFile(c.Hyperlinks(1).Address)
            c.Offset(, 1) = Format(f.Size / 1048576, "0.00MB")
            c.Offset(, 2) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
            c.Offset(, 3) = f.DateCreated
            c.Offset(, 4) = f.DateLastModified
         End If
      End With
Next
Range("a2:e" & r).Sort [e2], xlDescending, , , , , , xlNo
End Sub

anymole · 发表于 2018-1-13 18:20

2016不能运行。。

ivccav · 发表于 2018-1-13 18:39

anymole 发表于 2018-1-13 18:20
2016不能运行。。

显示这个窗体只是装饰，对程序功能没有任何影响。
你直接在程序中移除有关该窗体的部分就行了。
（下面3句红色部分）

Sub allfiles()

Set fdo = Application.FileDialog(msoFileDialogFolderPicker)
If fdo.Show = -1 Then
      pth = fdo.SelectedItems(1)
Else
      MsgBox "您没有选择文件夹！按『确定』键结束", vbCritical
      Exit Sub
End If
UserForm1.Show 0
DoEvents
Application.ScreenUpdating = False
With ActiveSheet
      .UsedRange.Clear
      .Cells(1, 1) = "文件序号"
      .Cells(1, 2) = "文件名称"
      .Cells(1, 3) = "创建日期"
      .Cells(1, 4) = "修改日期"
      .Cells(1, 5) = "文件类型"
      .Cells(1, 6) = "文件大小"
      Getfd (pth)

      r = .Range("b" & Rows.Count).End(3).Row
      For Each c In .Range("b2:b" & r)
         .Hyperlinks.Add Anchor:=c, Address:=c.Value, TextToDisplay _
         :=Split(c, "\")(UBound(Split(c, "\")))
      Next
      .Range("a1:f" & r).Borders.LineStyle = xlContinuous
      .Range("a1:f" & r).Borders.Weight = xlThin
End With
Application.ScreenUpdating = True
    Unload UserForm1
MsgBox "文件已全部获取！点『确定』键结束"
End Sub

lihuan_ · 发表于 2018-1-14 10:54

非常感谢楼主的分享，学习了！
有两个问题需要请教：
1.B列的数据当中我只需要.PDF或者.excel后缀的文件。其它格式的不要怎么操作呢？
2.需要在H列只显示第一级文件夹名称，I列显示H列下级文件夹名称，J列显示I列下级文件夹名称。
这些能直接点开路径。
感激不尽！

ivccav · 发表于 2018-1-14 16:35

lihuan_ 发表于 2018-1-14 10:54
非常感谢楼主的分享，学习了！
有两个问题需要请教：
1.B列的数据当中我只需要.PDF或者.excel后缀的文件 ...

筛选只是PDF和XLS的文件可以有，逐级显示文件夹路径没有意义，只写了一个筛选文件类型的，并显示该文件所在的文件夹。
想显示每一级文件夹，可以自己用split获取，按“\”分割然后循环就行了，在该程序中，获取最后一列可以用cells(r,columns.count).end(xltoleft).column，其中r是最后一行行号。

获取指定文件夹及其子文件夹下所有文件副本.zip (26.9 KB, 下载次数: 429)

Sub allfiles()

Set fdo = Application.FileDialog(msoFileDialogFolderPicker)
If fdo.Show = -1 Then
      pth = fdo.SelectedItems(1)
Else
      MsgBox "您没有选择文件夹！按『确定』键结束", vbCritical
      Exit Sub
End If
UserForm1.Show 0
DoEvents
Application.ScreenUpdating = False
With ActiveSheet
      .UsedRange.Clear
      .Cells(1, 1) = "文件序号"
      .Cells(1, 2) = "文件名称"
      .Cells(1, 3) = "创建日期"
      .Cells(1, 4) = "修改日期"
      .Cells(1, 5) = "文件类型"
      .Cells(1, 6) = "文件大小"
      .Cells(1, 7) = "文件路径"
      Getfd (pth)

      r = .Range("b" & Rows.Count).End(3).Row
      .Range("a1:f" & r).Borders.LineStyle = xlContinuous
      .Range("a1:f" & r).Borders.Weight = xlThin
End With
Application.ScreenUpdating = True
Unload UserForm1
MsgBox "文件已全部获取！点『确定』键结束"
End Sub
Sub Getfd(ByVal pth)
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(pth)
i = 1
For Each f In ff.Files
      If InStr("PDF/XLS", UCase(Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1))) Then
         r = Cells(Rows.Count, 1).End(3).Offset(1).Row
         Cells(r, 1) = i: i = i + 1
         With Cells(r, 2)
            .Value = f
            .Hyperlinks.Add Anchor:=Cells(r, 2), Address:=.Value, TextToDisplay:=Split(.Value, "\")(UBound(Split(.Value, "\")))
         End With
         Cells(r, 3) = f.DateCreated
         Cells(r, 4) = f.DateLastModified
         Cells(r, 5) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
         Cells(r, 6) = Format(f.Size / 1048576, "0.00MB")
         With Cells(r, 7)
            .Value = ff.Path
            .Hyperlinks.Add Anchor:=Cells(r, 7), Address:=.Value, TextToDisplay:=.Value
         End With
      End If
Next
For Each fd In ff.subfolders
      Getfd (fd)
Next
End Sub