VBA для заполнения последнего сохраненного пользователя и последней сохраненной даты файла

Question

Я использовал приведенный ниже код для получения имен файлов из папок, который работает отлично, но мне нужно сделать небольшую настройку.Мне нужно добавить, чтобы получить следующее и заполнить его в электронной таблице:

• Файл, последний раз обновленный (столбец O)
• Дата последнего обновления файла (столбец P)
• Гиперссылка файла на электронную таблицу (столбец Q)

Может ли кто-нибудь помочь мне обновить этот код, чтобы включить их?

Код:

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

Answer 1

Вот пример доступа к расширенным свойствам документа через Dsofile.dll.32-битная версия здесь .Я использую переписанную 64-битную альтернативу robert8w8 .После установки 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. Гиперссылки. Добавить метод