count open files in a dir help

[Trevor]

I am trying to count open files in a directory( dir will vary so the dir path is a string
all I have so far is pathedic

Dim stdir as sring

stDir = text1 ' dir is in textbox 'text1' and is now = to stDir
' and how to count open files in that dir I can' figure out other then Len(somthing here)

[Oorang]

Hi Trevor,
This should get you started. I haven't break tested it really hard. A few things to point out. "Open" is relative. Just because a file is opened does not mean that it is locked. It could be opened by a program that loads the file into memory or a temp file but does not lock the file against other edits (example: notepad). You should, instead, think of it in terms of what accesses are available. Can I write? Can I read?
The second piece of this puzzle is, of course, iterating through a folder of files. The microsoft scripting runtime provides a very easy to use interface for this, but it is also probably the slowest in terms of execution speed so you may want to find alternatives for big shares etc.

Option Explicit

'Determine whether a file is already open or not
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lClose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long

Public Sub TestGetOpenFiles()
MsgBox GetOpenFiles(Environ$("TEMP"), True)
End Sub

Public Function GetOpenFiles(ByVal path As String, _
Optional ByVal doSubDirectories As Boolean = False _
) As Long
Const lngErrPermissionDenied_c As Long = 70
'Requires reference to Microsoft Scripting Runtime (Scrrun.dll)
Dim fso As Scripting.FileSystemObject
Dim fldr As Scripting.Folder
Dim fl As Scripting.File
Dim fldrs As Scripting.Dictionary
Dim sbFldr As Scripting.Folder
Dim lngKey As Long
Dim lngRtnVal As Long
Dim lngItm As Long
On Error GoTo Err_Hnd
Set fso = New Scripting.FileSystemObject
Set fldr = fso.GetFolder(path)
If doSubDirectories Then
Set fldrs = New Scripting.Dictionary
fldrs.Add CStr(lngKey), fldr
lngKey = 1
Do
Set fldr = fldrs.Items(lngItm)
For Each fl In fldr.Files
If IsFileAlreadyOpen(fl.path) Then
lngRtnVal = lngRtnVal + 1
End If
NextFile1:
Next
For Each sbFldr In fldr.SubFolders
fldrs.Add CStr(lngKey), sbFldr
lngKey = lngKey + 1
Next
NextFolder:
lngItm = lngItm + 1
Loop Until lngItm = lngKey
Else
For Each fl In fldr.Files
If IsFileAlreadyOpen(fl.path) Then
lngRtnVal = lngRtnVal + 1
End If
NextFile2:
Next
End If
GetOpenFiles = lngRtnVal
Exit_Proc:
On Error Resume Next
'Release Objects:
Set fso = Nothing
Set fldr = Nothing
Set fl = Nothing
Set fldrs = Nothing
Set sbFldr = Nothing
Exit Function
Err_Hnd:
Select Case Err.Number
Case lngErrPermissionDenied_c
If doSubDirectories Then
If fl Is Nothing Then
Resume NextFolder
Else
Resume NextFile1
End If
Else
If fl Is Nothing Then
Resume Exit_Proc
Else
Resume NextFile2
End If
End If
Case Else
MsgBox Err.Description
End Select
Resume Exit_Proc
Resume
End Function

Private Function IsFileAlreadyOpen(FileName As String) As Boolean
Const OF_SHARE_EXCLUSIVE = &H10
Const lngErrSharing_c As Long = 32
Const lngErrNone_c As Long = -1
Dim hFile As Long
Dim lastErr As Long
'Modified from original All-API example by
'Matthew Gates
' Initialize file handle and error variable.
hFile = lngErrNone_c
' Open for for read and exclusive sharing.
hFile = lOpen(FileName, OF_SHARE_EXCLUSIVE)
' If we couldn't open the file, get the last error.
If hFile = lngErrNone_c Then
lastErr = Err.LastDllError
Else
' Make sure we close the file on success.
lClose hFile
End If
' Check for sharing violation error.
IsFileAlreadyOpen = (hFile = lngErrNone_c) And (lastErr = lngErrSharing_c)
End Function

[Trevor]

Thanks Aaron,
I'll give it a try and let you know, I was thinkin' about using filelock, but when I realy think about it I think Filelock proporty may not be the best suited for this.

[Trevor]

Aaron, I keep getting erron: onclick only comments can appear below end sub, end fuction, I looked but can't seem to find any offending code: can you help:
and yes I do have a scriptin run time refference

Option Explicit
Private Sub Command0_Click()

'Determine whether a file is already open or not
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lClose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long

'Public Sub TestGetOpenFiles()
' MsgBox GetOpenFiles(Environ$("TEMP"), True)
End Sub

Public Function GetOpenFiles(ByVal path As String, _
Optional ByVal doSubDirectories As Boolean = False _
) As Long
Const lngErrPermissionDenied_c As Long = 70
'Requires reference to Microsoft Scripting Runtime (Scrrun.dll)
Dim fso As Scripting.FileSystemObject
Dim fldr As Scripting.Folder
Dim fl As Scripting.File
Dim fldrs As Scripting.Dictionary
Dim sbFldr As Scripting.Folder
Dim lngKey As Long
Dim lngRtnVal As Long
Dim lngItm As Long
On Error GoTo Err_Hnd
Set fso = New Scripting.FileSystemObject
Set fldr = fso.GetFolder("C:\Temp\")
If doSubDirectories Then
Set fldrs = New Scripting.Dictionary
fldrs.Add CStr(lngKey), fldr
lngKey = 1
Do
Set fldr = fldrs.Items(lngItm)
For Each fl In fldr.Files
If IsFileAlreadyOpen(fl.path) Then
lngRtnVal = lngRtnVal + 1
End If
NextFile1:
Next
For Each sbFldr In fldr.SubFolders
fldrs.Add CStr(lngKey), sbFldr
lngKey = lngKey + 1
Next
NextFolder:
lngItm = lngItm + 1
Loop Until lngItm = lngKey
Else
For Each fl In fldr.Files
If IsFileAlreadyOpen(fl.path) Then
lngRtnVal = lngRtnVal + 1
End If
NextFile2:
Next
End If
GetOpenFiles = lngRtnVal
Exit_Proc:
On Error Resume Next
'Release Objects:
Set fso = Nothing
Set fldr = Nothing
Set fl = Nothing
Set fldrs = Nothing
Set sbFldr = Nothing
Exit Function
Err_Hnd:
Select Case Err.Number
Case lngErrPermissionDenied_c
If doSubDirectories Then
If fl Is Nothing Then
Resume NextFolder
Else
Resume NextFile1
End If
Else
If fl Is Nothing Then
Resume Exit_Proc
Else
Resume NextFile2
End If
End If
Case Else
MsgBox Err.Description
End Select
Resume Exit_Proc
Resume
End Function

Private Function IsFileAlreadyOpen(FileName As String) As Boolean
Const OF_SHARE_EXCLUSIVE = &H10
Const lngErrSharing_c As Long = 32
Const lngErrNone_c As Long = -1
Dim hFile As Long
Dim lastErr As Long
'Modified from original All-API example by
'Matthew Gates
' Initialize file handle and error variable.
hFile = lngErrNone_c
' Open for for read and exclusive sharing.
hFile = lOpen(FileName, OF_SHARE_EXCLUSIVE)
' If we couldn't open the file, get the last error.
If hFile = lngErrNone_c Then
lastErr = Err.LastDllError
Else
' Make sure we close the file on success.
lClose hFile
End If
' Check for sharing violation error.
IsFileAlreadyOpen = (hFile = lngErrNone_c) And (lastErr = lngErrSharing_c)
End Function

[Norie]

Trevor

Why have you put these declarations within a sub?
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lClose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long

If anything should go in there it should be a call to the function.

[Trevor]

Thanks Norie, I don't know how I managed to put them in a sub and not notice

[Trevor]

Aaron, .. To let you know pupose of counting open files in a dir. is because if there aren't any file open then the conents of the folder can be moved to a new folder, hope this gives you a little more insite as to why i'm tying to do this

[Trevor]

I'm looking at looping though files in folder & for each file in folder
If File = Case 70 then msgbox a file in x folder is open
If Case 0 Then Next file
' thats my sudo code
' i've only looped though a folder once , a few month ago so this isn't fresh in my mind I know I'll need to use fso, then step through the files with a for Each statment.
Thanks for helping,

[Trevor]

This is the code I have to step through files in a dir to see if a file is open then add the file path (if file is open) so SfoundPath then msgbox all open files. in a list format in msgbox. I keep getting an error on Do Untill .EOF, I would like to do this operation untill all files are checkd, I have tried Do untill folderCollect = 0 , Do Until folderCollect.EOF( both with no luck places knowin my luck) , and I'm getting error Arg not defined on checkfiles, and checkFolder :-)

Private sFondFilePath As String ' holds the path to the file if it is found
Private FileFound As Boolean ' set to True if the file is found
Private Sub Command0_Click()
)

' this routine searches all folders and sub-folders, parameters are:
' fsoFolder = a scripting folder object
' sFName = the file we are searching for
' create objects for a Files and a Folders collection, plus another Folder object

Dim FileCollect As Scripting.Files
Dim FolderCollect As Scripting.Folders
Dim fsoNextFolder As Scripting.Folder
Dim OFile As Long
Dim Ferr As Long
Set FileCollect = Scripting.FileSystemObject
Set FileCollect = New Scripting.FileSystemObject
Set FolderCoilect = fso.GetFolder("c:\windows")
Do Until EOF
' get the files collection in this folder and then see if we can find the file we want
Set FileCollect = fsoFolder.Files
CheckFiles FileCollect
' if we didn't find it, check the folder’s subfolders
If FileFound = False Then
' get the collection of all subfolders in this folder
Set FolderCollect = fsoFolder.SubFolders
' check each sub folder and all its subfolders
For Each fsoNextFolder In FolderCollect
CheckFolder fsoNextFolder, sFName
OFile = FolderCollect
Open FileName For Input Lock Read As #OFile
Close OFile
Ferr = Err
Select Case Ferr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
sFaundFilePath = FileName
Case Else: Error Ferr
End Select
' exit if we found the file
''If FileFound = True Then Exit For
Next fsoNextFolder
End If
MsgBox sFondFilePath & Chr$(32) & "is Open"
Loop
End Sub

[Trevor]

Update, I got Oorang's Reply to work by adding a WSH Refference in addition to MS Scipting object refference, I'm reverting back to his code now, and scrapping the code I posted

[Trevor]

I am trying to msg the open file(s) path and name along with the open # of files but not having any luck, I keep getting an object required error tword the botoo of getopenfile fuction where getopenfiles =

Option Compare Database
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lClose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long



Private Sub Command2_Click()
Call TestGetOpenFiles
End Sub
'Determine whether a file is already open or not


Public Sub TestGetOpenFiles()
MsgBox GetOpenFiles("C:\Windows\")
End Sub

Public Function GetOpenFiles(ByVal Path As String, _
Optional ByVal doSubDirectories As String = False _
) As String
Const lngErrPermissionDenied_c As Long = 70
'Requires reference to Microsoft Scripting Runtime (Scrrun.dll)
Dim fso As Scripting.FileSystemObject
Dim fldr As Scripting.Folder
Dim fl As Scripting.File
Dim fldrs As Scripting.Dictionary
Dim sbFldr As Scripting.Folder
Dim lngKey As Long
Dim lngRtnVal As Long
Dim lngItm As Long
On Error GoTo Err_Hnd
Set fso = New Scripting.FileSystemObject
Set fldr = fso.GetFolder(Path)
If doSubDirectories Then
Set fldrs = New Scripting.Dictionary
fldrs.Add CStr(lngKey), fldr
lngKey = 1
Do
Set fldr = fldrs.Items(lngItm)
For Each fl In fldr.Files
If IsFileAlreadyOpen(fl.Path) Then
lngRtnVal = lngRtnVal + 1
End If
NextFile1:
Next
For Each sbFldr In fldr.SubFolders
fldrs.Add CStr(lngKey), sbFldr
lngKey = lngKey + 1
Next
NextFolder:
lngItm = lngItm + 1
Loop Until lngItm = lngKey
Else
For Each fl In fldr.Files
If IsFileAlreadyOpen(fl.Path) Then
lngRtnVal = lngRtnVal + 1
End If
NextFile2:
Next
End If
GetOpenFiles = "There are file(s) Open " & lngRtnVal & VBNewLine & fl.Path & VBNewLine
Exit_Proc:
On Error Resume Next
'Release Objects:
Set fso = Nothing
Set fldr = Nothing
Set fl = Nothing
Set fldrs = Nothing
Set sbFldr = Nothing
Exit Function
Err_Hnd:
Select Case Err.Number
Case lngErrPermissionDenied_c
If doSubDirectories Then
If fl Is Nothing Then
Resume NextFolder
Else
Resume NextFile1
End If
Else
If fl Is Nothing Then
Resume Exit_Proc
Else
Resume NextFile2
End If
End If
Case Else
MsgBox Err.Description
End Select
Resume Exit_Proc
Resume
End Function

Private Function IsFileAlreadyOpen(FileName As String) As Boolean
Const OF_SHARE_EXCLUSIVE = &H10
Const lngErrSharing_c As Long = 32
Const lngErrNone_c As Long = -1
Dim hFile As Long
Dim lastErr As Long
'Modified from original All-API example by
'Matthew Gates
' Initialize file handle and error variable.
hFile = lngErrNone_c
' Open for for read and exclusive sharing.
hFile = lOpen(FileName, OF_SHARE_EXCLUSIVE)
' If we couldn't open the file, get the last error.
If hFile = lngErrNone_c Then
lastErr = Err.LastDllError
Else
' Make sure we close the file on success.
lClose hFile
End If
' Check for sharing violation error.
IsFileAlreadyOpen = (hFile = lngErrNone_c) And (lastErr = lngErrSharing_c)
End Function

[Oorang]

I keep getting an object required error tword the botoo of getopenfile fuction where getopenfiles =
Say what now? :saywhat:

[Trevor]

sorry for the confusion,
since I'm using this of the "admin"(designed) backend, I'm using this to count files then display a message box of the # of files open and the file namaand path under it ie: partial sudo code
msgbox "There are " & x & " files open : " & vbnew line full filename and path & vbnew line
full file name & path .....

and I'm getting an error at the end of getopenfiles fuction where getopenfiles = lngRntVal fl or fl.path
there is is 'object reqired' or with block not set'
hope this is clearer

[Trevor]

the purpose of this is to check if files are open if not then move all contents to new directory, this is to prevent tryin to move the directory of files if any are be usesed by someone on the network, this directory "should"( I can't control what end user put in it" only contain email attachments that were stripted from email(s).

[Oorang]

I am not able to reproduce your error. I would suggest putting the original code in it's own module and then just calling it from wherever you need to.

[Trevor]

Ok Aaron, but the reason I wouldn't want to put it in its own mod is because I have read posts from people that moved there ealier mdbs to 07 and the moduals didn't show (appear) correctly under 07, so I have attached the form that produces the error.