VBA填充文件的最后保存的用户和最后保存的日期 [英] VBA to populate last saved user and last saved date of a file
问题描述
我一直在使用下面的代码来从文件夹中获取文件名,该文件名很完美,但是我需要进行一些小的调整.我需要添加内容以获取以下内容并将其填充到电子表格中:
I have been using the code below to get file names from folders which works perfectly but I need to make a minor adjustment. I need to add in to fetch the following and populate it on the spreadsheet:
- 文件最后由(列O)更新
- 文件上次更新日期(P列)
- 将文件超链接到电子表格(Q列)
有人可以帮助我更新此代码以包括这些代码吗?
Can someone help me update this code to include these?
代码:
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
推荐答案
以下是通过Dsofile.dll访问扩展文档属性的示例. 32位版本为此处.我正在使用 robert8w8 .安装后(对于我来说是64位版本),请转到工具>参考>添加对DSO OLE Document Properties Reader 2.1
的参考.它使您能够访问已关闭文件的扩展属性.显然,如果该信息不可用,则无法将其返回.
Here is an example accessing the extended document properties via Dsofile.dll. 32 bit version is here. I am using re-written 64 bit alternative by robert8w8. After installation, of 64 bit version in my case, you go Tools >References >Add a reference to DSO OLE Document Properties Reader 2.1
. It enables to access extended properties of closed files. Obviously, if the info is not available, it cannot be returned.
我在其中有一个可选的文件掩码测试,可以将其删除.
I have an optional filemask test in there which can be removed.
The DSO function is my re-write of a great sub that lists many more properties by 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
其他:
这篇关于VBA填充文件的最后保存的用户和最后保存的日期的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!