Reputation: 1214
There are multiple Excel files on a server (or network shared storage location).
I have an Access document that needs access to these Excel files to execute a certain function.
When one of these files is open I can not execute my VBA function.
I check if someone is using the file. This is in the code below.
Is it is possible to also find out who is using a file. I would notify them to close the file(s).
Some of the things I tried (these are not all, but I can’t find a few methods anymore that I tried too): https://chandoo.org/forum/threads/return-user-name-who-has-file-open.31447/ https://www.ozgrid.com/forum/forum/help-forums/excel-general/87346-vba-code-to-determine-who-has-file-open
In the last one they get the owner of the file and that is not the same as the one that is using the file at that moment. I tried it, but even then I sometimes get a username, but the username of the one that created the file and sometimes I get a SID (Security Identifier?).
Code to find out if the file is in use. This does not include anything to see who is using the file.
Sub TestFileOpened()
Dim filesArray As Variant
filesArray = Array("Map1.xlsx", "Map2.xlsx")
Dim fileLocation As String
fileLocation = "\\DESKTOP-NETWORK\SharedFolder\NetwerkTest\"
Dim message As String
For Each file In filesArray
If IsFileOpen(fileLocation & file) Then
message = message & vbNewLine & "File '" & file & "' is open!"
'Else
' message = message & vbNewLine & "File '" & file & "' is closed!"
End If
Next file
MsgBox message
End Sub
Function to check if the file is in use:
Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
Error errnum
End Select
End Function
Access and Excel are able to do exactly that when you try to manually open the file. Superuser post: https://superuser.com/questions/845084/how-to-get-excel-to-show-username-of-person-that-has-file-open
Upvotes: 4
Views: 6342
Reputation: 21
This is ingenious - but very slightly risky - but only because the subroutine modifies its input parameter! I've tarted it up a bit here, and also added a check for if the file is not in use by anyone! I've also enhanced it to make it more readable. This also fixes a bug affecting 13-character long login names (13 = x0d = vbCr!).
Function InUseBy(FileName As String) As String
'
' This fixes:
' a. 13 character long usernames
' b. does not modify the supplied FileName value
'
' Note: not tested on Excel-sharable workbooks
'
Dim WorkFile As String
Dim TempFile As String
Dim iptr As Integer
Dim buffer As String
Dim fso As Object
Dim NameLength As Integer
Dim rezult As Variant
'
' Invent a temporary workfile name
'
WorkFile = Environ("TEMP") & "\Workfile" & CStr(Int(Rnd * 1000))
'
' Derive the Excel temporary file that will exist if it's open for update
'
iptr = InStrRev(FileName, "\")
If iptr > 0 Then
TempFile = Mid(FileName, 1, iptr) & "~$" & Mid(FileName, 1 + iptr)
Else
TempFile = "~$" & FileName
End If
'
' If the temporary file does not exist then the supplied file is either not open, or it's open read-only
'
If Dir(TempFile, vbHidden + vbSystem) = "" Then
'
' - it's not open, or open read-only
'
InUseBy = "No-one, or open read-only"
'
' Else copy the contents of the temporary file to the workfile
'
Else
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile TempFile, WorkFile
'
' - try to open the workfile
'
On Error Resume Next
Set ts = fso.GetFile(WorkFile).OpenAsTextStream(1, -2)
rezult = Err.Number
On Error GoTo 0
'
' -- if successful then extract the user's username
' (the INPUT approach fails if username is length 13, because it sees x0D as a carriage-return character!)
' (record format is Nusername... where N is the length of username (max 255))
'
If rezult = 0 Then
buffer = ts.readall
ts.Close
Set ts = Nothing
'
NameLength = Asc(buffer)
InUseBy = Mid(buffer, 2, NameLength)
'
' -- else return an error
'
Else
InUseBy = "Error " & rezult & " reading temporary file"
End If
'
' - delete the workfile
'
fso.Deletefile WorkFile
Set fso = Nothing
End If
End Function
Upvotes: 2
Reputation: 14899
Ok, i am not good in writing descent macro's, so modify code to suit your own needs!
This one should give the name of the user who has currently opened an Excel-sheet:
Sub InUse(filename As String)
Dim f
Dim i
Dim x
Dim inUseBy
Dim tempfile
tempfile = Environ("TEMP") + "\tempfile" + CStr(Int(Rnd * 1000))
f = FreeFile
i = InStrRev(filename, "\")
If (i > 0) Then
filename = Mid(filename, 1, i) + "~$" + Mid(filename, 1 + i)
Else
filename = "~$" + filename
End If
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile filename, tempfile
Open tempfile For Binary Access Read As #f
Input #f, x
Close (f)
inUseBy = Mid(x, 2, Asc(x))
fso.Deletefile tempfile
Set fso = Nothing
MsgBox "InUse by: " + inUseBy, vbOKOnly, "InUse"
End Sub
Example use:
InUse("T:\Book1.xlsx")
Things to note:
Upvotes: 3