Solved: MsgBox code to check for Existence of and Opened Files

[xluser2007]

Hi All,

I have the following code to open set of workbooks that are listed in a range specified as an input to the macro:

[VBA]Option Explicit

Sub Open_Workbooks_in_Range(rngWorkbookstoOpen As Range)

Dim rngoneCell As Range

For Each rngoneCell In rngWorkbookstoOpen

If FileFolderExists(CStr(rngoneCell.Value)) = True And WorkbookIsOpen(CStr(rngoneCell.Value)) = False Then

Workbooks.Open Filename:=CStr(rngoneCell.Value), UpdateLinks:=0

End If

Next rngoneCell

End Sub[/VBA]

This is fine, but before running this macro, I would like some code to loop through the same range and in a MsgBox Output, list the following:

1. List of Files that don't exists in the given range
2. List of Existing and Opened Files and which User (the environ variable) has them open.

I know it is a simple loop to build the above, but am not sure how to load the list in a single array which can be neatly output in the MsgBox. As such, I have a possible template for the code, but require some help to help me complete it.

[VBA]Option Explicit

Sub Code_to_Loop_and_ListFilesMsgbox(rngWorkbookstoOpen As Range)

Dim rngoneCell As Range

For Each rngoneCell In rngWorkbookstoOpen

If FileFolderExists(CStr(rngoneCell.Value)) = False Then

' code here to list all the files that don;t exist, so we
' can output them to the MsgBox in one message at the end

End If

If WorkbookIsOpen(CStr(rngoneCell.Value)) = False Then

' code here to list all the files that are open and the ENVIRON varible
' of the user who has them open
' so we can output them to the MsgBox in one message at the end

End If

Next rngoneCell

' Need code here to LIST ALL of the above files in the 2 categories in a single MsgBox
' Categories should just be separated by a Return Key in the Msgbox

End Sub[/VBA]

thanks and regards

[xluser2007]

Please note that IF a file is open, then CHECKING for the USERNAME of the person that has opened it is a non-trivial exercise.

I found some great code that solves this problem, as pasted below, written by Ivan Moala from this link:

[vba]Option Explicit



'===========================================

'http://www.xcelfiles.com/IsFileOpenVBA.htm

'===========================================



Sub TestVBA()

'// Just change the file to test here

Const strFileToOpen As String = "C:\Data.xls"



If IsFileOpen(strFileToOpen) Then

MsgBox strFileToOpen & " is already Open" & _

vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"

Else

MsgBox strFileToOpen & " is not open", vbInformation

End If

End Sub



Function IsFileOpen(strFullPathFileName As String) As Boolean

'// VBA version to check if File is Open

'// We can use this for ANY FILE not just Excel!

'// Ivan F Moala

'// http://www.xcelfiles.com

Dim hdlFile As Long



'// Error is generated if you try

'// opening a File for ReadWrite lock >> MUST BE OPEN!

On Error GoTo FileIsOpen:

hdlFile = FreeFile

Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile

IsFileOpen = False

Close hdlFile

Exit Function

FileIsOpen:

'// Someone has it open!

IsFileOpen = True

Close hdlFile

End Function



Private Function LastUser(strPath As String) As String

'// Code by Helen from http://www.visualbasicforum.com/index.php?s=

'// This routine gets the Username of the File In Use

'// Credit goes to Helen for code & Mark for the idea

'// Insomniac for xl97 inStrRev

'// Amendment 25th June 2004 by IFM

'// : Name changes will show old setting

'// : you need to get the Len of the Name stored just before

'// : the double Padded Nullstrings

Dim strXl As String

Dim strFlag1 As String, strflag2 As String

Dim i As Integer, j As Integer

Dim hdlFile As Long

Dim lNameLen As Byte





strFlag1 = Chr(0) & Chr(0)

strflag2 = Chr(32) & Chr(32)



hdlFile = FreeFile

Open strPath For Binary As #hdlFile

strXl = Space(LOF(hdlFile))

Get 1, , strXl

Close #hdlFile



j = InStr(1, strXl, strflag2)



#If Not VBA6 Then

'// Xl97

For i = j - 1 To 1 Step -1

If Mid(strXl, i, 1) = Chr(0) Then Exit For

Next

i = i + 1

#Else

'// Xl2000+

i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)

#End If



'// IFM

lNameLen = Asc(Mid(strXl, i - 3, 1))

LastUser = Mid(strXl, i, lNameLen)



End Function[/vba]
If anybody could please help use this code to help me with my original query, that would be really appreciated.

[xluser2007]

That's fine managed to Solve it, here is the solution for other people to benefit from:

[vba]Option Explicit

Sub Code_to_Loop_and_ListFilesMsgbox(rngWorkbookstoOpen As Range)

Dim rngoneCell As Range
Dim strFilesNotExistMsg As String
Dim strFilesExistbutOpenMsg As String

strFilesNotExistMsg = ""
strFilesExistbutOpenMsg = ""

For Each rngoneCell In rngWorkbookstoOpen

If FileFolderExists(CStr(rngoneCell.Value)) = False Then

' code here to list all the files that don;t exist, so we
' can output them to the MsgBox in one message at the end

strFilesNotExistMsg = strFilesNotExistMsg & vbCrLf & CStr(rngoneCell.Value)


End If


If FileFolderExists(CStr(rngoneCell.Value)) And WorkbookIsOpen(CStr(rngoneCell.Value)) = False Then

' code here to list all the files that are open and the ENVIRON varible
' of the user who has them open
' so we can output them to the MsgBox in one message at the end

strFilesExistbutOpenMsg = strFilesExistbutOpenMsg & vbCrLf & _
CStr(rngoneCell.Value) & " BY: " & UCase(LastUser(CStr(rngoneCell.Value)))

End If

Next rngoneCell

' Clear the immediate window before printing the Files that don't exist or are open
DeleteTextInDebugWindow2

Debug.Print Trim(strFilesNotExistMsg)
Debug.Print Trim(strFilesExistbutOpenMsg)

Select Case Trim(strFilesNotExistMsg) = "" And Trim(strFilesExistbutOpenMsg) = ""

Case True

Open_Workbooks_in_Range rngWorkbookstoOpen

Exit Sub

Case False

If Trim(strFilesNotExistMsg) = "" Then

strFilesNotExistMsg = "All workbooks Exist, but ALL/ SOME of the workbooks are open, please see below for details"

End If

If Trim(strFilesExistbutOpenMsg) = "" Then

strFilesExistbutOpenMsg = "All workbooks are closed, but ALL/ SOME of the workbooks are NOT CREATED, please see above for details"

End If

Call MsgBox("The Following Files are NOT CREATED yet:" _
& vbCrLf & "" _
& strFilesNotExistMsg & "" _
& vbCrLf & "" _
& vbCrLf & "The Following FILES are OPEN by the following USERS:" _
& vbCrLf & "" _
& strFilesExistbutOpenMsg & "" _
& vbCrLf & "" _
& vbCrLf & "Please ensure that all files are created before re-running and any open files are closed." _
, vbCritical Or vbDefaultButton1, "The Following Files Don't Exist or are Open!")

Exit Sub

End Select

End Sub

Sub Open_Workbooks_in_Range(rngWorkbooksListtoOpen As Range)

Dim rngoneCell As Range

For Each rngoneCell In rngWorkbooksListtoOpen

If FileFolderExists(CStr(rngoneCell.Value)) = True And WorkbookIsOpen(CStr(rngoneCell.Value)) = False Then

Workbooks.Open Filename:=CStr(rngoneCell.Value), UpdateLinks:=0

End If

Next rngoneCell

End Sub

'===========================================

'http://www.xcelfiles.com/IsFileOpenVBA.htm

'===========================================


Private Function LastUser(strPath As String) As String

'// Code by Helen from http://www.visualbasicforum.com/index.php?s=

'// This routine gets the Username of the File In Use

'// Credit goes to Helen for code & Mark for the idea

'// Insomniac for xl97 inStrRev

'// Amendment 25th June 2004 by IFM

'// : Name changes will show old setting

'// : you need to get the Len of the Name stored just before

'// : the double Padded Nullstrings

Dim strXl As String

Dim strFlag1 As String, strflag2 As String

Dim i As Long, j As Long

Dim hdlFile As Long

Dim lNameLen As Byte

strFlag1 = Chr(0) & Chr(0)

strflag2 = Chr(32) & Chr(32)

hdlFile = FreeFile

Open strPath For Binary As #hdlFile

strXl = Space(LOF(hdlFile))

Get 1, , strXl

Close #hdlFile

j = InStr(1, strXl, strflag2)

#If Not VBA6 Then

'// Xl97

For i = j - 1 To 1 Step -1

If Mid(strXl, i, 1) = Chr(0) Then Exit For

Next

i = i + 1

#Else

'// Xl2000+

i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)

#End If

'// IFM

lNameLen = Asc(Mid(strXl, i - 3, 1))

LastUser = Mid(strXl, i, lNameLen)

End Function

Sub test()

Code_to_Loop_and_ListFilesMsgbox ThisWorkbook.Worksheets("OPEN Tools by Listing").Range("OPEN_ABCD_Tools")

End Sub[/vba]
Please note that there is a amcro to clear the immediate window called "DeleteTextInDebugWindow2", this is sourced from http://chrisrae.com/vba/routines/deletetextindebugwindow2.html.

regards,