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位版本为here。我正在使用robert8w8重写的64位替代方法。安装后（对于我来说是64位版本），请转到工具>参考>添加对DSO OLE Document Properties Reader 2.1的参考。它允许访问已关闭文件的扩展属性。显然，如果该信息不可用，则无法将其返回。

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

DSO函数是我对一个很棒的子程序的重写，该子程序通过xld here列出了更多的属性。

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

其他

：

Hyperlinks.Add method

Answer 2

在我的情况下，我无法使用 dsofile.dll 中的 DSO 库（需要管理员才能安装并注册它...），所以我想出了另一种解决方案来获取 Office 文档的一些 OLE 属性，而无需打开它们。似乎（一些？）这些扩展属性也可以通过 Shell 访问：

Function GetDateLastSaved_Shell32(strFileFullPath$)

    strFolderPath$ = Left(strFileFullPath, Len(strFileFullPath) - Len(Dir(strFileFullPath)))
    strFileName$ = Dir(strFileFullPath)

    'using late binding here
    'to use early binding with Dim statements you need to reference the Microsoft Shell Controls And Automation library, usually available here:
    'C:\Windows\SysWOW64\shell32.dll
    'Example: 
    'Dim shlShell As Shell32.Shell 

    Set shlShell = CreateObject("Shell.Application") 'Variant/Object/IShellDispatch6
    'Set shlFolder = shlShell.Namespace(strFolderPath)                              'does not work when using late binding, weird...*
    Set shlFolder = shlShell.Namespace(CStr(strFolderPath))                         'works...
    'Set shlFolder = shlShell.Namespace(strFolderPath & "")                         'works...
    'Set shlFolder = shlShell.Namespace(Left$(strFolderPath, Len(strFolderPath)))   'works...

    '*also mentioned here without an explanation...
    'https://stackoverflow.com/questions/35957930/word-vba-shell-object-late-binding
   
    Set shlShellFolderItem = shlFolder.ParseName(strFileName)
    
    'all of the following returns the same thing (you have the returned Data Type indicated on the right)
    'but the first one is said by MSDN to be the more efficient way to get an extended property
    GetDateLastSaved_Shell32 = shlShellFolderItem.ExtendedProperty("{F29F85E0-4FF9-1068-AB91-08002B27B3D9} 13")  'Date
    'GetDateLastSaved_Shell32 = shlShellFolderItem.ExtendedProperty("System.Document.DateSaved")                 'Date
    'GetDateLastSaved_Shell32 = shlShellFolderItem.ExtendedProperty("DocLastSavedTm")                            'Date      'legacy name   
    'GetDateLastSaved_Shell32 = shlFolder.GetDetailsOf(shlShellFolderItem, 154)                                  '?String?

End Function

要列出所有扩展属性（核心、文档等），您可以使用：

For i = 0 To 400
    vPropName = shlFolder.GetDetailsOf(Null, i)
    vprop = shlFolder.GetDetailsOf(shlShellFolderItem, i)
    Debug.Print i, vPropName, vprop
    If i Mod 10 = 0 Then Stop
Next

您可以在 MSDN 上找到有关“高效方式”的更多信息：ConversationPaused

如果您安装了 Visual Studio，您还可以在来自 Windows SDK 的 propkey.h 或 C:\Program Files (x86)\Windows Kits\10\Include\***VERSION***\um\ 中的某处找到 FMTID 和 PIDSI 的列表。

VBA填充文件的最后保存的用户和最后保存的日期

2 个答案: