VBA Support: Checking if file is locked on Sharepoint

[MrRodger]

Hi All, I am attempting to build a macro that will loop through all files in a given sharepoint folder that I have mapped to a drive, check if they are currently locked for editing by another user, if they are locked for editing it will skip over them, if they are not locked it will open, update and save the workbooks. I can get this to work for single files as shown in the first sub below but once I try to loop through the directory the code fails. Any help on what I am doing wrong would be very much appreciated.

I have confirmed that the 'Opentester' code in conjunction with the 'FileLocked' function below can check single files and confirm if they are locked on my sharepoint site. The issue I am still having is how to loop through and perform this command on all files in a given folder.

Sub Opentester()
OpenFile:
   Dim Myfile As String
   Dim Mybook As Workbook
   Myfile = "L:\afilepath.xlsm"
   If Not FileLocked(Myfile) Then
      Set Mybook = Workbooks.Open(Myfile)
      ActiveWorkbook.LockServerFile
      'do other stuff
   Else
      'read / write file in use
      msg = MsgBox("File Is Locked For Editing By Another User." & Chr(10) & _
               "Do You Want To Try Again?", 36, "File Locked")
      If msg = 6 Then GoTo OpenFile
   End If
End Sub

Here is the function I use on both subs

Function FileLocked(strFileName As String) As Boolean
   On Error Resume Next
   ' If the file is already opened by another process,
   ' and the specified type of access is not allowed,
   ' the Open operation fails and an error occurs.
   Open strFileName For Binary Access Read Write Lock Read Write As 1
   Close #1
   ' If an error occurs, the document is currently open.
   FileLocked = IIf(Err.Number = 0, False, True)
   On Error GoTo 0
End Function

But when I try to loop through the files it does not correctly check if the file is locked for editing.

Sub Opentester()
OpenFile:
   MyPath = "L:\afolderpath\"
   myExtension = "*.xlsm"
   Myfile = Dir(MyPath & myExtension)
   Do While Myfile <> ""
      If Not FileLocked(Myfile) Then
         Set wb = Workbooks.Open(Myfile)
         wb.LockServerFile
         DoEvents
         wb.RefreshAll 'refreshes all connections in current workbook
         DoEvents 'waits until refresh action is complete
         wb.Close savechanges:=True 'Saves and Closes Workbook in one line! Sweet
         On Error Resume Next 'if something goes wrong loop to the next file
         Myfile = Dir 'Get next file name
         'do other stuff
         
         'Message Box when tasks are completed
         MsgBox "All workbooks Updated?!"
      Else
         'read / write file in use
         msg = MsgBox("File Is Locked For Editing By Another User." & Chr(10) & _
         "Do You Want To Try Again?", 36, "File Locked")
         If msg = 6 Then GoTo OpenFile
      End If
   Loop 'repeat all of above for the next file
End Sub

I use the same function on both pieces of code. Its not clear to me what I am doing wrong but the vba fails to properly check and ends up crashing when it loops into a locked file.

 

[dmt32]

Hi,
In your Dir Loop, MyFile variable is only returning the File Name – your function & workbook Open require the Path as well as the File Name to be included.

If FileLocked(mypath & myFile) Then
 
Set wb = Workbooks.Open(mypath & myFile)

Not tested but see if this update to your code helps:

 Sub Opentester()   
    Dim mypath As String, msg As String
    Dim myExtension As String, myFile As String
    Dim Response As Integer


    mypath = "L:\afolderpath\"
    myExtension = "*.xlsm"
    myFile = Dir(mypath & myExtension)
    
    DoWhile myFile <> ""
    If FileLocked(mypath & myFile) Then
        'read / write file in use
        Response = MsgBox("File Is Locked For Editing By Another User." & Chr(10) & _
                          "Do You Want To Try Again?", 36, "File Locked")
        If Response = 7 Then myFile = Dir


    Else
        On Error GoTo myerror
        Set wb = Workbooks.Open(mypath & myFile)
        wb.LockServerFile
        DoEvents
        wb.RefreshAll    'refreshes all connections in current workbook
        DoEvents    'waits until refresh action is complete
        wb.Close savechanges:=True    'Saves and Closes Workbook in one line! Sweet

        myFile = Dir    'Get next file name

        'do other stuff
        If Len(msg) = 0 Then
            msg = "The Follwing Workbooks Have Been Updated:" & Chr(10) & myFile & Chr(10)
        Else
            msg = msg & myFile & Chr(10)
        End If
    End If

    Set wb = Nothing
Loop    'repeat all of above for the next file


'Message Box when tasks are completed
If Len(msg) > 0 Then MsgBox msg, 48, "Workbooks Updated"


myerror:
If Err <> 0 Then
    Response = MsgBox((Error(Err)) & Chr(10) & _
                      "Do You Want To Continue?", 36, "Error")
     If Response = 6 Then Err.Clear: Resume Next


    EndSub

Hope Helpful

Dave

 

[MrRodger]

Hi Dave,

This has worked great! I have continued to modify your code to work with sub-folders and its been a huge help.