VBA function to get username of open file on network?

BrianB said:

Try my code below. Works in Excel 2000. I would be interested to here if it works in your version of Excel.

Code:

'=======================================================================================
'- ACCESS A .XLS FILE TO GET LAST USER NAME
'- CAN ALSO BE USED IF THE FILE IS IN USE
'- NB. This code works in XL97 and XL2000 - don't know about others
'=======================================================================================
'- NB.1.Cannot get this by *opening* the workbook because we then become the last user.
'-    2.Not the same as the "Last saved by" property which requires opening the workbook.
'-    3.No security. A user can change their name temporarily in Tools/Options.
'=======================================================================================
'- Last user name is preceded by characters [\][0][p][0][??][0][0]
'- [??] is a variable character - its code shows the number of characters in the name.
'- followed by any number of spaces (and can include spaces)
'- Method : Use a Regular Expression to find the precedes + 50 following characters
'-          ..... then use the [??] character to extract the string
'- Brian Baulsom December 2007
'========================================================================================
Sub GetLastUser()
    Dim MyFile As String            ' File name
    Dim MyRegExp As Object
    Dim MyLastUser                  ' last user name
    Dim LastUserLen As Integer      ' character 5 name length
    Dim FileString As String        ' file converted to a string in memory
    Dim MyMatches As Variant        ' RegExp array of matches (should only be 1)
    Dim MyLastSaved As String       ' "Last saved by" from properties
    '---------------------------------------------------------------------------------
    ChDrive "F:\"
    ChDir "F:\"
    MyFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
    If MyFile = "False" Then End
    '----------------------------------------------------------------------------------
    '- PUT THE FILE INTO MEMORY AND CLOSE IT
    Open MyFile For Binary Access Read Shared As #1
        FileString = Space(LOF(1))
        Get 1, 1, FileString
    Close #1
    '----------------------------------------------------------------------------------
    '- SET UP A REGULAR EXPRESSION
    Set MyRegExp = CreateObject("VbScript.RegExp")
    With MyRegExp
        .Global = True
        .Pattern = "\\\x00p\x00.\x00\x00.{50}"      ' 57 characters should be enough
        Set MyMatches = .Execute(FileString)        ' zero based array
        '------------------------------------------------------------------------------
        '- DISPLAY RESULTS (should only be 1 match = Matches(0))
        '------------------------------------------------------------------------------
        '- check only 1
        If MyMatches.Count <> 1 Then
            MsgBox ("Found " & MyMatches.Count & " matches" & vbCr _
                    & "Only showing first one.")
        End If
        '------------------------------------------------------------------------------
        '- exclude first 7 characters & trailing spaces
        MyLastUser = MyMatches(0)                       ' 57 characters found
        LastUserLen = Asc(Mid(MyLastUser, 5, 1))        ' length of name
        MyLastUser = Mid(MyLastUser, 8, LastUserLen)    ' extract name
        '------------------------------------------------------------------------------
        '- Message
        rsp = MsgBox(MyFile & vbCr & "Last user : " & MyLastUser)
        '--------------------------------------------------------------------------------
        FileString = ""
    End With
    '------------------------------------------------------------------------------------
End Sub
'========================================================================================

Click to expand...