Who Has My Workbook Open? [VBA]

A while back I posted some C# code which would find out if someone is locking an Excel workbook and identify who they are. At the time I didn’t post a VBA equivalent because I had linked to a VBA solution on StackOverflow. Well, I recently needed to do it in VBA and I found that the answer on SO didn’t work on directories on unmapped drives. Not wanting to let you down, here’s a working solution which has been adapted from a Microsoft Support article:

Option Explicit

'adapted from https://support.microsoft.com/en-us/kb/218965
'requires a reference to Microsoft Scripting Runtime (scrrun.dll)

Private Const mlngERROR_INSUFFICIENT_BUFFER As Long = 122&

#If Win64 Then
    'https://msdn.microsoft.com/en-us/library/windows/desktop/aa446639(v=vs.85).aspx
    Private Declare PtrSafe Function GetFileSecurity Lib "advapi32.dll" Alias "GetFileSecurityA" ( _
       ByVal lpFileName As String, _
       ByVal RequestedInformation As Long, _
       ByRef pSecurityDescriptor As Byte, _
       ByVal nLength As Long, _
       ByRef lpnLengthNeeded As Long _
       ) As Long

    'https://msdn.microsoft.com/en-us/library/windows/desktop/aa446651(v=vs.85).aspx
    Private Declare PtrSafe Function GetSecurityDescriptorOwner Lib "advapi32.dll" ( _
        ByRef pSecurityDescriptor As Any, _
        ByRef pOwner As LongPtr, _
        ByRef lpbOwnerDefaulted As LongPtr) As Long

    'https://msdn.microsoft.com/en-gb/library/windows/desktop/aa379166(v=vs.85).aspx
    Private Declare PtrSafe Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" ( _
       ByVal lpSystemName As String, _
       ByVal Sid As LongPtr, _
       ByVal name As String, _
       ByRef cbName As Long, _
       ByVal ReferencedDomainName As String, _
       ByRef cbReferencedDomainName As Long, _
       ByRef peUse As LongPtr) As Long

#Else
    Private Declare Function GetFileSecurity Lib "advapi32.dll" Alias "GetFileSecurityA" ( _
       ByVal lpFileName As String, _
       ByVal RequestedInformation As Long, _
       ByRef pSecurityDescriptor As Byte, _
       ByVal nLength As Long, _
       ByRef lpnLengthNeeded As Long _
       ) As Long

    Private Declare Function GetSecurityDescriptorOwner Lib "advapi32.dll" ( _
        ByRef pSecurityDescriptor As Any, _
        ByRef pOwner As Long, _
        ByRef lpbOwnerDefaulted As Long) As Long

    Private Declare Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" ( _
       ByVal lpSystemName As String, _
       ByVal Sid As Long, _
       ByVal name As String, _
       ByRef cbName As Long, _
       ByVal ReferencedDomainName As String, _
       ByRef cbReferencedDomainName As Long, _
       ByRef peUse As Long) As Long

#End If

Public Function GetWorkbookWriteOwner(ByRef strWorkbookFullName As String) As String
    
    'requires reference to Microsoft Scripting Runtime
    Dim fso As Scripting.FileSystemObject
    Dim strFileName As String
    Dim strFolderPath As String
    Dim strTempFilePath As String

    Set fso = CreateObject("Scripting.FileSystemObject")

    'check if a system temp file with a ~$ prefix exists in the same folder
    strFileName = fso.GetFileName(strWorkbookFullName)
    strFolderPath = fso.GetParentFolderName(strWorkbookFullName)
    strTempFilePath = fso.BuildPath(strFolderPath, "~$" & strFileName)

    'if it exists then the file is locked with write access
    'we can retrieve the creator of the temp file to determine who has
    'the write access
    If fso.FileExists(strTempFilePath) Then
        GetWorkbookWriteOwner = GetFileOwner(strTempFilePath)
    Else
        GetWorkbookWriteOwner = vbNullString
    End If

End Function

Private Function GetFileOwner(ByRef strFullFileName As String) As String

    Dim lngResult As Long
    Dim bytarrSecDesc() As Byte  'Buffer for Security Descriptor

    #If Win64 Then
        Dim lngOwnerSid As LongPtr  'Pointer to the owner's security identifier (SID)
    #Else
        Dim lngOwnerSid As Long
    #End If

    Dim strDomainName As String
    Dim strOwnerName As String

    'get the file owner's security information
    lngResult = GetFileOwnerSecurityInfo(strFullFileName, bytarrSecDesc)

    '0 indicates failure
    If lngResult = 0 Then
        MsgBox CStr(Err.LastDllError)

    Else
        ' get the owner's SID
        lngResult = GetSecurityDescriptorOwner(bytarrSecDesc(0), lngOwnerSid, 0&)

        '0 indicates failure
        If lngResult = 0 Then
            MsgBox CStr(Err.LastDllError)
        Else

            'get the owner's 1st domain and account name
            lngResult = GetAccountNameFromSID(lngOwnerSid, strDomainName, strOwnerName)

            '0 indicates failure
            If lngResult = 0 Then
                MsgBox CStr(Err.LastDllError)
            Else
                If LenB(strOwnerName) = 0 Then
                    GetFileOwner = "unknown"
                Else
                    GetFileOwner = strDomainName & "\" & strOwnerName
                End If
            End If

        End If
    End If

End Function

Private Function GetFileOwnerSecurityInfo( _
    ByRef strFullFileName As String, _
    ByRef bytarrSecDesc() As Byte) As Long

    'SECURITY_INFORMATION:
    'https://msdn.microsoft.com/en-us/library/windows/desktop/aa379573(v=vs.85).aspx
    Const lngOWNER_SECURITY_INFORMATION As Long = &H1

    Dim lngResult As Long           ' API call result
    Dim lngSizeSID As Long          ' Buffer size to store Owner's SID

    ' get the size of the
    ' buffer required for the Security Descriptor.
    lngResult = GetFileSecurity( _
            strFullFileName, _
            lngOWNER_SECURITY_INFORMATION, _
            0, _
            0&, _
            lngSizeSID)

    '0 indicates failure
    If lngResult = 0 And Err.LastDllError <> mlngERROR_INSUFFICIENT_BUFFER Then
          MsgBox CStr(Err.LastDllError)
    Else

        ' Create a buffer of the required size and call again
        ReDim bytarrSecDesc(0 To lngSizeSID - 1) As Byte

        ' The calling process must have READ_CONTROL rights to retrieve the owner
        GetFileOwnerSecurityInfo = GetFileSecurity( _
                strFullFileName, _
                lngOWNER_SECURITY_INFORMATION, _
                bytarrSecDesc(0), _
                lngSizeSID, _
                lngSizeSID)
    End If

End Function

#If Win64 Then
    Private Function GetAccountNameFromSID(ByVal lngOwner As LongPtr, ByRef strDomainName As String, ByRef strOwnerName As String) As Long
#Else
    Private Function GetAccountNameFromSID(ByVal lngOwner As Long, ByRef strDomainName As String, ByRef strOwnerName As String) As Long
#End If

    Dim lngResult As Long           ' API call result
    Dim lngDomainLength As Long     ' Required length for the domain name
    Dim lngOwnerLength As Long      ' Required length for the owner name

    ' Pointer to a SID_NAME_USE value which indicates the type of account
    'https://msdn.microsoft.com/en-gb/library/windows/desktop/aa379601(v=vs.85).aspx
    #If Win64 Then
        Dim lngUse As LongPtr
    #Else
         Dim lngUse As Long
    #End If

    ' Call LookupAccountSid twice:
    ' the first time
    ' to obtain the required size of the owner and domain names.
    lngResult = LookupAccountSid( _
                    vbNullString, _
                    lngOwner, _
                    strOwnerName, _
                    lngOwnerLength, _
                    strDomainName, _
                    lngDomainLength, _
                    lngUse)

    '0 indicates failure
    If lngResult = 0 And Err.LastDllError <> mlngERROR_INSUFFICIENT_BUFFER Then
        MsgBox CStr(Err.LastDllError)
    Else

        'both the account and domain are null terminated strings
        'so allocate 1 byte less to avoid the appended null character.
        strOwnerName = Space$(lngOwnerLength - 1)
        strDomainName = Space$(lngDomainLength - 1)

        GetAccountNameFromSID = LookupAccountSid( _
                        vbNullString, _
                        lngOwner, _
                        strOwnerName, _
                        lngOwnerLength, _
                        strDomainName, _
                        lngDomainLength, _
                        lngUse)
    End If

End Function

To use it just call the GetWorkbookWriteOwner() procedure and pass in the full name of the workbook: