vba - 如何填充文件的最后保存用户和最后保存日期
问题描述
我有下面的代码从文件夹中获取文件名。
Sub GetFileNames_Assessed_As_T2()
Dim sPath As String, sFile As String
Dim iRow As Long, iCol As Long
Dim ws As Worksheet: Set ws = Sheet9
'declare and set the worksheet you are working with, amend as required
sPath = "Z:\NAME\T2\"
'specify directory to use - must end in ""
sFile = Dir(sPath)
Do While sFile <> ""
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row 'get last row on Column I
Filename = Left(sFile, InStrRev(sFile, ".") - 1) 'remove extension from file
Set FoundFile = ws.Range("I1:I" & LastRow).Find(what:=Filename, lookat:=xlWhole) 'search for existing filename
If FoundFile Is Nothing Then ws.Cells(LastRow + 1, "I") = Filename 'if not found then add it
sFile = Dir ' Get next filename
Loop
End Sub
我需要进行调整以获取以下内容并将其填充到电子表格中:
- 文件最后更新者(O 列)
- 文件最后更新日期(P 列)
- 将文件超链接到电子表格(Q 列)
解决方案
这是一个通过 Dsofile.dll 访问扩展文档属性的示例。32 位版本在这里。我正在使用robert8w8重写的 64 位替代方案。安装后,在我的情况下,64 位版本,你去工具>参考>添加对DSO OLE Document Properties Reader 2.1
. 它可以访问已关闭文件的扩展属性。显然,如果信息不可用,则无法返回。
我在那里有一个可以删除的可选文件掩码测试。
DSO 函数是我对一个很棒的 sub 的重写,它在此处列出了 xld 的更多属性。
Option Explicit
Public Sub GetLastestDateFile()
Dim FileSys As Object, objFile As Object, myFolder As Object
Const myDir As String = "C:\Users\User\Desktop\TestFolder" '< Pass in your folder path
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set myFolder = FileSys.GetFolder(myDir)
Dim fileName As String, lastRow As Long, arr(), counter As Long
With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet where writing info to
lastRow = .Cells(.Rows.Count, "P").End(xlUp).Row 'find the last row with data in P
For Each objFile In myFolder.Files 'loop files in folder
fileName = objFile.Path
If FileSys.GetExtensionName(fileName) = "xlsx" Then 'check if .xlsx
arr = GetExtendedProperties(fileName)
counter = counter + 1
.Cells(lastRow + counter, "O") = arr(0) 'Last updated
.Cells(lastRow + counter, "P") = arr(1) 'Last save date
.Hyperlinks.Add Anchor:=.Cells(lastRow + counter, "Q"), Address:=objFile.Path '<== Add hyperlink
End If
Next objFile
End With
End Sub
Public Function GetExtendedProperties(ByVal FileName As String) As Variant
Dim fOpenReadOnly As Boolean, DSO As DSOFile.OleDocumentProperties
Dim oSummProps As DSOFile.SummaryProperties, oCustProp As DSOFile.CustomProperty
Dim outputArr(0 To 1)
Set DSO = New DSOFile.OleDocumentProperties
DSO.Open FileName, fOpenReadOnly, dsoOptionOpenReadOnlyIfNoWriteAccess
Set oSummProps = DSO.SummaryProperties
outputArr(0) = oSummProps.LastSavedBy
outputArr(1) = oSummProps.DateLastSaved
GetExtendedProperties = outputArr
End Function
其他:
推荐阅读
- reactjs - 反应 require("history").createBrowserHistory` 而不是 `require("history/createBrowserHistory")
- c++ - 尝试将文本文件读入 C++ 中的结构数组
- python - 为什么我在询问用户输入时收到“AttributeError:'builtin_function_or_method' 对象没有属性'lapcount'”?
- android - 尝试使用 youtube api 从 json 中提取视频 ID
- javascript - NodeJS如何加速这个数组创建功能
- php - 为什么 DB::table 中 leftJoin 的结果与 DB::select 中的左连接不同?
- php - 如何将此mysql旧代码转换为MYSQLI
- python-3.x - 通过 SSH 与树莓派通信
- c# - C# Linq Where Date Between 2 Dates 如果日期以字符串格式存储在数据库中
- java - Android 多屏灵活性