Dynamic File - Last Saved by

[Armstrong_N14]

Good Day, Everyone!
Hope this SOS finds you all in good health.
I can't seem to put the right syntax for the builtinproperties code to show the last author of a specific file due to the twist that the file that needs to show who saved it last is a different file from where the builtinproperties code is being written.

Example:
Checker.xlsm is the file that has a table that shows the breakdown of files with it's last saved time stamp and last author, in each file in the list, there is a corresponding cell that shows the path of the file where it it saved. I was able to show the last saved time stamp but not the last author(last saved by)


Sample code:

Funtion Lastauthor()

Lastauthor=Thisworkbook. Builtinproperties("Last Author")

End function

I'd like to put the file path on the Thisworkbook portion of the code but I can't seem to make it to work.

Please help me. Thanks a lot in advance.

 

[Jaafar Tribak]

@Armstrong_N14

This works for Owner of the file - but what I want was "the Last Touch".
The rest, I get 0 as the value - either I substituted some of the values incorrectly or I dunno. time for me to give up.

I see... As I have been saying throughout this thread, retrieving the *Last Saved By* via the shell namesapce gives inconsistent results at best.

Is the workbook from which you are trying to get the *Last Saved By* info large in size?

I did write some code that decompresses the file in order to get to the core.xml and take the *last saved by* info from there , but although it works, it is extremely slow when the workbook is too heavy. In fact, decompressing a workbook, further increases its size.

Hopefully, i will be posting later some new code that uses MSAA which should work regardless of the size of the file. So stay tuned.

 

[Jaafar Tribak]

Ok- Here is what I have arrived to... The approach I am using here is kind of brute but it is fast and works w/o the need to open the workbook, to uncompress it or to use the shell namespace method which is inconsistent as we seen here.

Basically, this method programmatically reads the required extended property straight from the file shell context menu. It should work as well on other file types besides excel workbooks.

Since the code reads from the screen based on the accessibilty interface (Included in the Office library - No third party dependencies required.) , it is language dependent. This means, the code (as is) will only work on standard English systems. For other languages, the code will need a slight tweaking.


Tested on Win10 x64 ( xl2013 x32 and xl2016 x64) ... I hope I get some feedback on this code to know if it works accross diff plateforms. Thank you.


Oops!!! Code being edited .... I will post it next.

 

[Jaafar Tribak]

Sorry, here is the code :

File Demo:
LastSavedBy.xlsm


1- Place this code in a Standard Module:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function ShellExecuteEx Lib "Shell32" (ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
#Else
    Private Enum LongPtr
            [_]
    End Enum
    Private Declare Function ShellExecuteEx Lib "Shell32" (ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "oleacc.dll" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function GetLastError Lib "kernel32" () As Long
#End If

Enum ERROR_CODES
    ERROR_FILE_NOT_FOUND = 2&
    ERROR_PATH_NOT_FOUND = 3&
    ERROR_ACCESS_DENIED = 5&
    ERROR_NOT_ENOUGH_MEMORY = 8&
    ERROR_NO_ASSOC = 31&
    ERROR_SHARING_VIOLATION = 32&
    ERROR_CANCELLED = 1223&
    ERROR_DDE_FAIL = 1156&
End Enum

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As LongPtr
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As LongPtr
    'Optional fields
    lpIDList As LongPtr
    lpClass As String
    hkeyClass As LongPtr
    dwHotKey As Long
    hIcon As LongPtr
    hProcess As LongPtr
End Type

Private bProcessing As Boolean



'\\ Note: The code in this vba project uses the accessibility library therefore, it is language dependent.
       'So, for languages other than standard english, the code will need some slight tweaking.

Public Function GetExtendedFileProperty(ByVal FilePathName As String, ByVal PropertyName As String) As String

    If IsWindow(GetProp(Application.hwnd, "Hidden")) Or bProcessing = False Then
        Call DestroyWindow(GetProp(Application.hwnd, "Hidden"))
    End If
    If bProcessing Then Exit Function
    bProcessing = True
    GetExtendedFileProperty = "File not found."
    If Len(Dir(FilePathName)) And IsPathFile(FilePathName) Then
        GetExtendedFileProperty = ExtendedPropertyFromFile(FilePathName, PropertyName)
    End If
    bProcessing = False
   
End Function


' ________________________________________ PRIVATE HELPER SUBS ________________________________________________

Private Function ExtendedPropertyFromFile(ByVal FilePathName As String, ByVal PropertyName As String) As String

    Const CHILDID_SELF = 0&, NAVDIR_FIRSTCHILD = 7&
    Const WM_SYSCOMMAND = &H112, SC_CLOSE = &HF060&
    Dim oAccContextMenu As IAccessible, oAccChild As IAccessible
    Dim hwnd As LongPtr, lChildCount As Long
    Dim sFileName As String, bPropertyFound As Boolean
    Dim sOutputString As String, sngTimer As Single
       
    ExtendedPropertyFromFile = "Extended Property: [" & PropertyName & "] doesn't exist."
    Call DestroyWindow(GetProp(Application.hwnd, "Hidden"))
    If InvokeShellContextMenu(FilePathName) Then
        sFileName = Split(FilePathName, Application.PathSeparator) _
                    (UBound(Split(FilePathName, Application.PathSeparator)))
        sngTimer = Timer
        Application.EnableCancelKey = xlDisabled
        On Error Resume Next
        Do
            'DoEvents
            If Timer - sngTimer >= 5! Then GoTo Xit
            'Language dependent.
            hwnd = FindWindow("#32770", sFileName & " Properties")
            Call SetParent(hwnd, GetProp(Application.hwnd, "Hidden"))
        Loop Until hwnd
        Set oAccContextMenu = HwndToAcc(hwnd)
        If Not oAccContextMenu Is Nothing Then
            Set oAccChild = oAccContextMenu.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
            For lChildCount = 0& To 2&
                Set oAccChild = oAccChild.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
            Next lChildCount
            If Not oAccChild Is Nothing Then
                For lChildCount = 0& To oAccChild.accChildCount - 1&
                    If LCase(oAccChild.accName(lChildCount)) = LCase(PropertyName) Then
                        sOutputString = CleanUpString _
                                ((Trim(Replace((oAccChild.accDescription(lChildCount)), "Value:", ""))))
                        If Len(sOutputString) Then
                            ExtendedPropertyFromFile = sOutputString
                        End If
                        Exit For
                    End If
                Next
            End If
        End If
    End If
Xit:
    If GetLastError Then
        ExtendedPropertyFromFile = "Error: " & FormatErrorCode(GetLastError)
    End If
    Call SendMessage(hwnd, WM_SYSCOMMAND, SC_CLOSE, ByVal 0&)
    Call DestroyWindow(GetProp(Application.hwnd, "Hidden"))

End Function

Private Function InvokeShellContextMenu(ByVal FilePathName As String) As Boolean

  Const SW_SHOW = 5&, SEE_MASK_INVOKEIDLIST = &HC, WS_VISIBLE = &H10000000, WS_EX_TOOLWINDOW = &H80
  Dim tShInfo As SHELLEXECUTEINFO, hHiddenWindow As LongPtr

    hHiddenWindow = CreateWindowEx( _
                        WS_EX_TOOLWINDOW, StrPtr("EDIT"), StrPtr(Chr(10&)), WS_VISIBLE, _
                        -200&, -200&, 1&, 1&, NULL_PTR, NULL_PTR, _
                        GetModuleHandle(StrPtr(vbNullString)), ByVal 0& _
                    )
    If hHiddenWindow Then
        Call SetProp(Application.hwnd, "Hidden", hHiddenWindow)
        With tShInfo
            .cbSize = LenB(tShInfo)
            .lpFile = FilePathName & vbNullChar
            .nShow = SW_SHOW
            .fMask = SEE_MASK_INVOKEIDLIST
            'Language dependent.
            .lpVerb = "Properties"
            .lpParameters = "Details" & vbNullChar
        End With
        InvokeShellContextMenu = ShellExecuteEx(tShInfo)
        If tShInfo.hInstApp > 32& Then
            Call SetLastError(CLng(tShInfo.hInstApp))
        End If
    End If
   
End Function

Private Function HwndToAcc(ByVal hwnd As LongPtr) As IAccessible

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_CLIENT = &HFFFFFFFC, S_OK = &H0&
   
    Dim tGUID(0& To 3&) As Long
    Dim oIAc As IAccessible
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0&))) = S_OK Then
        If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0&)), oIAc) = S_OK Then
           Set HwndToAcc = oIAc
        End If
    End If
   
End Function

Private Function FormatErrorCode(ByVal errCode As ERROR_CODES) As String
    Select Case errCode
        Case ERROR_FILE_NOT_FOUND:       FormatErrorCode = "File not found"
        Case ERROR_PATH_NOT_FOUND:       FormatErrorCode = "Path not found"
        Case ERROR_ACCESS_DENIED:        FormatErrorCode = "Access denied"
        Case ERROR_NOT_ENOUGH_MEMORY:    FormatErrorCode = "Not enough memory"
        Case ERROR_NO_ASSOC:             FormatErrorCode = "No file association"
        Case ERROR_SHARING_VIOLATION:    FormatErrorCode = "Sharing violation"
        Case ERROR_CANCELLED:            FormatErrorCode = "Cancelled"
        Case ERROR_DDE_FAIL:             FormatErrorCode = "DDE fail"
    End Select
End Function

Private Function CleanUpString(ByVal sString As String) As String
    Dim i As Long
    For i = 1& To Len(sString)
        If Asc(Mid(sString, i, 1&)) <> 63& Then
            CleanUpString = CleanUpString & Mid(sString, i, 1&)
        End If
    Next
End Function

Private Function IsPathFile(ByVal Path As String) As Boolean
    IsPathFile = CBool(GetAttr(Path) = vbArchive)
End Function

2- Code Usages Example(s):

Option Explicit

Sub Test1()
    'Change The FilepathName and Extended Property to suit.
    MsgBox GetExtendedFileProperty(FilePathName:="C:\SHAREDFOLDER\Sample.xlsm", PropertyName:="Last Saved By")
End Sub

Sub Test2()
    'Change The FilepathName and Extended Property to suit.
    MsgBox GetExtendedFileProperty(FilePathName:="C:\test\data.txt", PropertyName:="name")
End Sub

 

[Dan_W]

Two thoughts come to mind:

1. If its 32bit office, there is the 32bit dsofile.dll method that is discussed on Chip Pearson's blog: here. From memory, it works nicely and has the added benefit of being able to write properties for MSDOCS as well, but has the complication that it only works with 32bit Office, and that it requires the download of the additional DLL. http://www.cpearson.com/excel/docprop.asp
2. I remembered that @johnnyL and I used a brute-forcey kind of method to extract out the individual files from the Workbook ZIP container - Alternative approach to fix those problematic excel files when excel sees 1048576 as the last row # & you can't fix it. - the code there can be adapted easily to get the core.xml file which you helpfully pointed to above. I've noticed that using this method allows you to get the contents of the individual file without having to decompress the entire ZIP container - which is useful when reading and writing files to existing ZIP files. This method, however, requires the file to be renamed as a ZIP before it works (I think, from memory). The approach we used in this example, copies the target file to a backup files (renamed as ZIP), and then works on that - this can result in a performance hit, but it's the approach I opted for because I am forever concerned about something going wrong with my code. I expect it will be fast just by renaming the file.

 

[Dan_W]

I started writing this hours ago, so only just saw that you had come up with a solution using APIs - this is great!

I did a test re: speed/performance, unsurprisingly, your approach blitzed the approach used in the referenced link above - I adjusted the code so that I tested the approach where it worked on a copy of the file versus simply renaming the file, and as I suspected, the renaming of the target file was quicker. The results I got (using a simple Timer method) was:

Win32 API method (JT)	0.385
Shell - Extract File from Copy of Original	2.588
Shell - Extract File from Renamed Original	1.302

 

[Dan_W]

I should add that my proposal above has the additional issue of diminishing returns - the larger the file, the slower it will be.

And I've just thought of a third option - Cristian Buse has a project that parses ZIP files (principally, in his demo, Excel workbooks) and that can extract the data of individual using the DEFLATE algorithm, which is doubtless much quicker than my proposal, though I haven't been able to time it properly because the Timer method isn't high resolution enough:

GitHub - cristianbuse/Excel-ZipTools: Interact with the component parts of an Excel file

Interact with the component parts of an Excel file - cristianbuse/Excel-ZipTools

github.com

I've adjust the democode in his demo workbook to extract the lastModifiedBy property - hardcoded demo code below:

Public Sub DEMO_Property()
    
    Dim filePath As String
    filePath = "D:\testworkbook.xlsx"
    
    Dim zip As New ExcelZIP: zip.Init filePath
    Dim b() As Byte
    Dim s As String
    
    zip.ReadData "docProps/core.xml", b
    s = StrConv(b, vbUnicode)
    
    Dim startIndex As Long
    Dim endIndex As Long
    
    startIndex = InStr(endIndex + 1, s, "lastModifiedby>", vbTextCompare)
    endIndex = InStr(startIndex + 1, s, "<", vbTextCompare)
    Debug.Print "Property found: " & Mid$(s, startIndex + 15, endIndex - startIndex - 15)
    
End Sub

I look forward to reading your solution Jaafar.

 

[Jaafar Tribak]

I started writing this hours ago, so only just saw that you had come up with a solution using APIs - this is great!

I did a test re: speed/performance, unsurprisingly, your approach blitzed the approach used in the referenced link above - I adjusted the code so that I tested the approach where it worked on a copy of the file versus simply renaming the file, and as I suspected, the renaming of the target file was quicker. The results I got (using a simple Timer method) was:

Win32 API method (JT)	0.385
Shell - Extract File from Copy of Original	2.588
Shell - Extract File from Renamed Original	1.302

Hi Dan,

Have you tried each method on *large size* workbooks (say over 100 kb).?

 

[Dan_W]

Hi Dan,

Have you tried each method on *large size* workbooks (say over 100 kb).?

I have not, and I concede that point in my most recent comment; you're absolutely right. For reference, my test workbook was 14kb in size.

 

[Jaafar Tribak]

And I've just thought of a third option - Cristian Buse has a project that parses ZIP files (principally, in his demo, Excel workbooks) and that can extract the data of individual using the DEFLATE algorithm, which is doubtless much quicker than my proposal, though I haven't been able to time it properly because the Timer method isn't high resolution enough:

GitHub - cristianbuse/Excel-ZipTools: Interact with the component parts of an Excel file

Interact with the component parts of an Excel file - cristianbuse/Excel-ZipTools

github.com

I've adjust the democode in his demo workbook to extract the lastModifiedBy property - hardcoded demo code below:

Public Sub DEMO_Property()
 
    Dim filePath As String
    filePath = "D:\testworkbook.xlsx"
 
    Dim zip As New ExcelZIP: zip.Init filePath
    Dim b() As Byte
    Dim s As String
 
    zip.ReadData "docProps/core.xml", b
    s = StrConv(b, vbUnicode)
 
    Dim startIndex As Long
    Dim endIndex As Long
 
    startIndex = InStr(endIndex + 1, s, "lastModifiedby>", vbTextCompare)
    endIndex = InStr(startIndex + 1, s, "<", vbTextCompare)
    Debug.Print "Property found: " & Mid$(s, startIndex + 15, endIndex - startIndex - 15)
 
End Sub

I look forward to reading your solution Jaafar.

Just saw Critian Buse's project. Nice!
I have tested his code to obtain the *Last Saved By* on a 100 kb file. It worked and it is surprisingly fast. I will need to study his project.

A quick test to get the the *Date Created* property didn't work though.

Public Sub DEMO_Property()
 
    Dim filePath As String
    filePath = "C:\SHAREDFOLDER\sample.xlsm"
 
    Dim zip As New ExcelZIP: zip.Init filePath
    Dim b() As Byte
    Dim s As String 
 
    zip.ReadData "xl/sharedStrings.xml", b
    s = StrConv(b, vbUnicode)
 
    Dim startIndex As Long
    Dim endIndex As Long
 
    startIndex = InStr(endIndex + 1, s, "Datecreated>", vbTextCompare)
    endIndex = InStr(startIndex + 1, s, "<", vbTextCompare)
    Debug.Print "Property found: " & Mid$(s, startIndex + 15, endIndex - startIndex - 15)
 
End Sub

Thanks.

 

[Dan_W]

That's great - I only just recently stumbled across it. I had already learnt how to read the file structure from ActiveVB (link), but had no idea how to identify and extract out the compressed data without using Shell.

As for the Date Modified data, I found the following in the core.xml in the docProps folder:

<cp:coreProperties xmlns:cp="http://schemas.openxmlformats.org/package/2006/metadata/core-properties" xmlns:dc="http://purl.org/dc/elements/1.1/" 
xmlns:dcterms="http://purl.org/dc/terms/" xmlns:dcmitype="http://purl.org/dc/dcmitype/" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<dc:creator>Dan_W</dc:creator><cp:lastModifiedBy>Dan_W</cp:lastModifiedBy><dcterms:created xsi:type="dcterms:W3CDTF">2023-10-08T12:07:13Z</dcterms:created>
<dcterms:modified xsi:type="dcterms:W3CDTF">2023-10-08T12:07:59Z</dcterms:modified></cp:coreProperties>

Is that what you were after?

This is from a 10mb workbook which, for completeness, I should report back - your API method managed to get the Last Saved By data in 0.5 whereas the shell/rename method took 7.5 - so as expected, the larger the file, the (excruciatingly) slower the result! I've just managed to take a look at your code - it's great. It would never have occurred to me to approach using IAccessible - @sancarn will doubtless be interested.