none
How do I find who has a file open? RRS feed

  • Question

  • Hi all,

    I am trying to find the username of the person who has an Excel file open.

    I have seen many posts but they all seem to give me the file owners name and not the person who currently has the file open.

    thanks


    • Edited by Gazza101 Tuesday, October 16, 2018 1:44 PM
    Tuesday, October 16, 2018 11:40 AM

All replies

  • This should work for Windows 10.  It first checks if file is open.  If it is open it checks who has it open.  Need to reference Microsoft Scripting Runtime.

    Option Explicit
    Option Base 0
    Option Private Module
    
    Sub Test()
    
      Dim f As String
      Dim who As String
      
      f = "C:\userdata\selenium\books\Books.xlsx"
      If IsXlsFileOpen(f) Then
        who = WhoHasXlsOpen(f)
        Debug.Print "File is open by: " & who
      End If
       
    End Sub
    
    Function IsXlsFileOpen(xlsPath As String) As Boolean
    
      Dim fso As New Scripting.FileSystemObject
      Dim fileNum As Integer
      
      On Error GoTo ErrHandler
      
      If fso.FileExists(xlsPath) Then
        fileNum = FreeFile()
        Open xlsPath For Input Lock Read As fileNum
        On Error Resume Next
        Close #fileNum
      End If
      Exit Function
    
    ErrHandler:
       IsXlsFileOpen = True
    End Function
    
    
    Function WhoHasXlsOpen(xlsPath As String) As String
    
      Dim fso As New Scripting.FileSystemObject
      Dim fileNum As Integer
      Dim xlsName As String
      Dim ext As String
      Dim lockFile As String
      Dim path As String
      Dim path2 As String
    
      On Error GoTo ErrHandler
    
      fileNum = FreeFile()
      path = fso.GetParentFolderName(xlsPath) & "\"
      ext = fso.GetExtensionName(xlsPath)
      xlsName = fso.GetBaseName(xlsPath)
    ' ********** Maybe Windows 7 - Don't have it to test
    '  If Len(xlsName) > 6 Then
    '    If Len(xlsName) = 7 Then
    '      path = path & "~$" & _
    '        Mid(xlsName, 2, Len(xlsName)) & "." & ext
    '    Else
    '      path = path & "~$" & _
    '        Mid(xlsName, 3, Len(xlsName)) & "." & ext
    '    End If
    '  Else
    '    path = path & "~$" & xlsName & "." & ext
    '  End If
    ' ******** Windows 10
      path = path & "~$" & xlsName & "." & ext
      path2 = path & "~$" & xlsName & "_copy." & ext
      fso.CopyFile path, path2
      WhoHasXlsOpen = ""
      If fso.FileExists(path2) Then
        Open path2 For Input Shared As #fileNum
        Line Input #fileNum, lockFile
        Close #fileNum
        fso.DeleteFile path2
        WhoHasXlsOpen = Trim(GetUserName(lockFile))
      End If
      Exit Function
    ErrHandler:
      WhoHasXlsOpen = ""
    End Function
    
    Function GetUserName(textStr As String) As String
     ' Non username chars before and after username. Not always the same.
      Dim userName As String
      Dim c As String
      Dim i As Integer
      
      i = 1
      c = Mid(textStr, 1, 1)
      While Not ((c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Or c = "." Or c = "-")
        i = i + 1
        c = Mid(textStr, i, 1)
      Wend
      
      While ((c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Or c = "." Or c = "-" Or c = " ") And i < 20
        userName = userName & c
        i = i + 1
        c = Mid(textStr, i, 1)
      Wend
      
      GetUserName = userName
    End Function
    
    
    

    Wednesday, October 17, 2018 12:48 AM