VBA - Checking if a file is already open

[photoman]

I have some code which opens the worksbooks in a folder in sequence and carries out some manipulation on them. What I can't get working is checking to see if the workbook is open and displaying a suitable message. The code I have for opening the files is as follows:

Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
.LookIn = nUNCpath
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
.Filename = "*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

' Rest of code here
Next lCount
End If
End With

I need something at the 'Set wbResults' line to check if the workbook is open by someone else.

 

[hiker95]

photoman.

See:
Is File Open
See Ivan Moala's page.
http://www.xcelfiles.com/IsFileOpen.html

 

[photoman]

hiker95 - That gave me something to work on. I tweaked it and part of what I want to do is check if the files are already open, and if so to report which ones are open. This works for one file being open, but when I come across a second open one, I get a run-time error 70: Permission denied. My current bit of code looks like this, and is giving me the error on the 'Open .FoundFiles(lCount) For Random Access Read Write Lock Read Write As hdlFile' line.

cFileList = ""
For lCount = 1 To .FoundFiles.Count 'Loop through all
cCurrentFile = .FoundFiles(lCount)
On Error GoTo FileIsOpen:
hdlFile = FreeFile
Open .FoundFiles(lCount) For Random Access Read Write Lock Read Write As hdlFile
Close hdlFile
GoTo EndLoop
FileIsOpen:
' Someone has it open
cFileList = cFileList + cCurrentFile + ", "
Close hdlFile
EndLoop:
Next lCount
' Display message
MsgBox ("The Following Files Are Currently Open -" & Chr(10) & Chr(10) & cFileList)

 

[hiker95]

photoman,

Please post all of your macro code.

At the beginning of your posted code, enter the following without the quote marks:
["code"]


'Your code goes here.


At the end of your posted code, enter the following without the quote marks:
["/code"]

 

[photoman]

Sub Workplan_Update()
'
' Workplan_Update Macro
'
 
Sheet1.Unprotect Password:="******"
Application.ScreenUpdating = False
Windows("Workplan.xls").Activate
' Get the path of where the files are stored. That way, the files can be moved to any location and won't need updating
' Removed last 6 characters to drop off Master folder part
nUNCpath = Left(ActiveWorkbook.Path, Len(ActiveWorkbook.Path) - 6)
 
' Delete existing data from Workbook before updating
Application.ScreenUpdating = False
ActiveCell.SpecialCells(xlLastCell).Select
nLC = ActiveCell.Address
If ActiveCell.Row <> 1 Then
    Range("A2", nLC).Select
    Selection.Delete
End If
' Select A2 to start process
Range("A2").Select
' repeat for all workbooks in folder
On Error Resume Next
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch
            .LookIn = nUNCpath
            .FileType = msoFileTypeExcelWorkbooks
            'Optional filter with wildcard
            .Filename = "*.xls"
                If .Execute > 0 Then 'Workbooks in folder
 
                    ' Check which files are open
                    cFileList = ""
                    For lCount = 1 To .FoundFiles.Count 'Loop through all
                        cCurrentFile = .FoundFiles(lCount)
                        hdlFile = FreeFile
                        On Error GoTo FileIsOpen:
                        Open .FoundFiles(lCount) For Random Access Read Write Lock Read Write As hdlFile
                        Close hdlFile
                        GoTo EndLoop
FileIsOpen:
                        ' Someone has it open
                        cCF = Left(Right(cCurrentFile, Len(cCurrentFile) - Len(nUNCpath)), Len(Right(cCurrentFile, Len(cCurrentFile) - Len(nUNCpath) - 4)))
                        cFileList = cFileList + cCF + Chr(10)
                        Close hdlFile
EndLoop:
                    Next lCount
                    ' Display message and exit macro
                    MsgBox ("The Following Files Are Currently Open -" & Chr(10) & Chr(10) & cFileList & Chr(10) & "The Workplan Will Not Update." & Chr(10) & Chr(10) & "Please Close All Open Files And Try Again.")
 
' Exit macro at this stage                    
' If no files open, process the rest of the macro
 
                    For lCount = 1 To .FoundFiles.Count 'Loop through all
                        'Open Workbook x and Set a Workbook variable to it
 
' Wrap the following code with File Open check once working above
' *********
                        Worksheets("Summary").Select
                        ActiveCell.SpecialCells(xlLastCell).Select
                        nLC = ActiveCell.Address
                        Range("A2", nLC).Select
                        Selection.Copy
                        Windows("Workplan.xls").Activate
                        ' Don't do for first Workbook
                        If lCount <> 1 Then
                            Range("A1").Select
                            Selection.End(xlDown).Select
                            ActiveCell.Offset(1, 0).Activate
                        End If
                        ActiveSheet.Paste
                        wbResults.Close SaveChanges:=False
' *********
                    Next lCount
                End If
        End With
On Error GoTo 0
 
' add hyperlinks to column B data
nURLRow = 2
Range("B1").Select
    ActiveCell.SpecialCells(xlLastCell).Select
' Selection.End(xlDown).Select
nLastRow = ActiveCell.Row
Do While nURLRow <= nLastRow
    nWBname = Range("A" & nURLRow) & ".xls"
    Range("B" & nURLRow).Select
    nFNtext = ActiveCell.Value
    nFNlink = "#'" & ActiveCell.Value & "'!A1"
    ActiveCell.Formula = "=HYPERLINK(""" & nUNCpath & nWBname & nFNlink & """,""" & nFNtext & """)"
    ' Repeat Contact name in Column G
    ActiveCell.Offset(0, 5).Activate
    ActiveCell.Value = Range("A" & ActiveCell.Row).Value
    nURLRow = nURLRow + 1
Loop
ActiveCell.Offset(1, -6).Activate
 
Application.ScreenUpdating = True
Sheet1.Protect Password:="******"
ActiveWorkbook.Save
Application.ScreenUpdating = False
End Sub

The above is all the code I have at the moment. It falls over at the 'Open .FoundFiles(lCount)' line. Once I get the first FileOpen check working, I then plan to wrap the lower code with the same check (just in case).

An example of the problem is as follows:

I will have 6 workbooks (A,B,C,D,E,F), one for each individual. This macro is in a separate workbook that collates the data from the other 6. If B and D are open already, I will get the Runtime error 70: Permission denied when I try to open workbook D. The code works fine when dealing with workbooks A,B and C. Hope this makes more sense.

 

[hiker95]

photoman,

Sorry for the delay.

I am not able to work on your request right now.

Create a new reply, and just use the word "BUMP", and someone else will assist you.

 

[photoman]

That's okay. I cheated slightly to get it working. Instead of it checking all the files and then listing the ones that were opened, it just displays a message saying that at least one file is open.

It would be nice to find out what the solution is, just in case I get asked to identify which files are open, as opposed to a generic message.