Checking if files are locked using VBA

In one of our client’s applications, we built an email template that sometimes may attach files to be sent out. Our client wanted a way to preview the attachment before they actually send the email. This created a dilemma – if they can preview and potentially edit the files, we certainly don’t want to continue and try to attach open files to an email, therefore creating a problem. So we needed a way to check whether files may be already open, alert the user to close the file, verify it’s closed then send the emails.

Get Exclusivity

Due to multitasking nature of Windows, there is no simple universal function to ask if a file, whatever type of file it may be, is open or not. However, we can at least approximate this functionality by attempting to open the file exclusively in our code and if we succeed, be reasonably sure that we are good to proceed onwards.

Introducing IsFileLocked() Function

When we open a text file with Notepad, Notepad does not place any locks on the file even when we dirty the file. In this situation, it does no harm to copy or read the file while it’s open by Notepad. Thus IsFileLocked() will return true for any .txt files opened by Notepad and in this situation, it’s generally OK. Of course, one shouldn’t try to write to the said file but that’s not what we are doing here. On the other hand, Word and Excel will place locks on their documents. Therefore trying to copy or read the file may be undesirable and threat it’s integrity. In this situation, our attempt to acquire an exclusive lock will fail, allowing us to alert the user to close the file themselves before proceeding further or cancel out.

The only significant caveat is that this procedure is not appropriate for checking whether a file is locked by other processes such as running background tasks. The locks can be acquired and released in milliseconds so calling the function is inherently racy. For purposes of checking whether users has a file open, this should be sufficient.

Public Function IsFileLocked(PathName As String) As Boolean
On Error GoTo ErrHandler
  Dim i As Integer

  If Len(Dir$(PathName)) Then
    i = FreeFile()
    Open PathName For Random Access Read Write Lock Read Write As #i
    Lock i 'Redundant but let's be 100% sure
    Unlock i
    Close i
  Else
    Err.Raise 53
  End If

ExitProc:
  On Error GoTo 0
  Exit Function

ErrHandler:
  Select Case Err.Number
    Case 70 'Unable to acquire exclusive lock
      IsFileLocked = True
    Case Else
      MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    End Select
  Resume ExitProc
  Resume
End Function

What if you have multiple files open?

That gets us to a good start but we also have to handle the fact that there may be more than one file open, and nobody likes being alerted by multiple dialogs. Thus we need to roll up the individual checks into a single message so the users can only see one message for all locked files that they may need to close. Here’s the code:

Public Function CheckForLockedFiles( _
  Files() As String _
) As Boolean
On Error GoTo ErrHandler
  Dim i As Long
  Dim lngLocks As Long
  Dim strFiles() As String
  Dim strMessage As String

  Do
    lngLocks = 0
    For i = 0 To UBound(Files)
      If IsFileOpen(Files(i)) Then
        ReDim Preserve strFiles(lngLocks)
        strFiles(lngLocks) = Files(i)
        lngLocks = lngLocks + 1
      End If
    Next
    If lngLocks Then
      strMessage = "The following files are in use. " & _
                   "Please close the application that may have it open." _
                   & vbNewLine & vbNewLine
      For i = 0 To UBound(strFiles)
        strMessage = strMessage & strFiles(i) & vbNewLine
      Next
      If vbCancel = MsgBox(strMessage, vbRetryCancel, "Files in use") Then
        CheckForLockedFiles = False
        Exit Do
      End If
    End If
  Loop Until lngLocks = 0
  If lngLocks = 0 Then
    CheckForLockedFiles = True
  End If

ExitProc:
  On Error GoTo 0
  Exit Function

ErrHandler:
  Select Case Err.Number
    Case 53 'File doesn't exist, ignore
      Resume Next
    Case Else
      MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
  End Select
  Resume ExitProc
  Resume
End Function