|
发表于 2016-6-22 13:17
|
显示全部楼层
本楼为最佳答案
代码如下:- Sub 提取()
- Dim fs As Object, fld As Object, fil As Object, f As Object
- Dim p As String
- Dim arr() As Variant
- Dim i As Integer
- Application.ScreenUpdating = False
- p = InputBox("请输入或复制指定路径" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "以下路径是默认值:" & Chr(10) & "------本模板所在的路径" & Chr(10) & "------<您可将新路径复制此下框内>", "哈哈哈", ActiveWorkbook.Path)
- Set fs = CreateObject("Scripting.FileSystemObject")
- Set fld = fs.getfolder(p)
- Set fil = fld.Files
- ReDim Preserve arr(1 To fil.Count, 1 To 5)
- For Each f In fil
- i = i + 1
- '设置或返回指定文件或文件夹名。读/写属性。
- 'arr(i, 1) = f.Name
- arr(i, 1) = Left(f.Name, InStr(f.Name, ".") - 1)
- '返回指定文件或文件夹的创建日期和时间。只读。
- arr(i, 2) = f.DateCreated
- '返回最后一次修改指定文件或文件夹的日期和时间。只读。
- arr(i, 3) = f.DateLastModified
- '返回最后一次访问指定文件或文件夹的日期和时间。只读。
- arr(i, 4) = f.DateLastAccessed
- '根据照片命名的格式,提取第5-13的日期。
- arr(i, 5) = Mid(f.Name, InStr(f.Name, ".") + 1, 9)
- Next f
- With Sheet2
- .Cells.Clear
- .Columns("b:b").NumberFormatLocal = "@"
- .[a1:i1] = Array("批量提取外部文档名称", "原始文档名称", "创建日期", "最后修改日期", "最后访问日期", "新名过渡A", "新名过渡B", "新名A&B", "原始文档路径")
- .Range("B2").Resize(UBound(arr), UBound(arr, 2)) = arr
- .Rows.Font.Name = "宋体"
- .Rows.Font.Size = 10
- .Cells(2, 9) = p '在[I2]单元格还原用户输入的路径
- End With
- Application.ScreenUpdating = True
- Sheet2.Activate
- End Sub
复制代码 |
|