如何填充上次保存的用户和文件的上次保存日期

我有下面的代码从文件夹中获取文件名。

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 位版本是here https://support.microsoft.com/en-gb/help/224351/the-dsofile-dll-files-lets-you-edit-office-document-properties-when-yo。我正在使用重写的 64 位替代方案罗伯特8w8 https://www.codeproject.com/tips/1118708/bit-application-can-not-use-dsofile。安装后，在我的情况下是 64 位版本，您可以转到“工具”>“参考”>“添加参考”DSO OLE Document Properties Reader 2.1。它允许访问已关闭文件的扩展属性。显然，如果信息不可用，则无法返回。

我在那里有一个可选的文件掩码测试，可以将其删除。

DSO 函数是我对一个很棒的子函数的重写，它列出了 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

Other:

1. 超链接.Add 方法 https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add