Help with listing files using Allen Browne's (modified) code

  • Thread starter Thread starter DawnTreader
  • Start date Start date
D

DawnTreader

Hello All

i am trying to make a list of the files in a specified directory that match
a piece of search critieria. for example i have a type of file, *.pdf, that
appears in a bunch of folders but i only want ones that have the word
"compressor" in the name of the file. so i modified Allen's code like this:

Option Compare Database
Option Explicit

'list files to tables
'http://allenbrowne.com/ser-59alt.html
Dim gCount As Long ' added by Crystal

'crystal modified parameter specification for strFileSpec by adding default
value
Public Function ListFilesToTable(strPath As String, Optional
strSearchFileName As String, Optional strFileSpec As String = "*.*", Optional
bIncludeSubfolders As Boolean)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from
subdirectories of strPath as well.
'Method: FilDir() adds items to a collection, calling itself
recursively for subfolders.

Dim colDirList As New Collection
Dim varitem As Variant
Dim rst As DAO.Recordset

Dim mStartTime As Date
Dim mSeconds As Long
Dim mMin As Long
Dim mMsg As String

mStartTime = Now()
'--------
gCount = 0

Call FillDirToTable(colDirList, strPath, strSearchFileName, strFileSpec,
bIncludeSubfolders)

mSeconds = DateDiff("s", mStartTime, Now())

mMin = mSeconds \ 60
If mMin > 0 Then
mMsg = mMin & " min "
mSeconds = mSeconds - (mMin * 60)
Else
mMsg = ""
End If

mMsg = mMsg & mSeconds & " seconds"

MsgBox "Done adding " & Format(gCount, "#,##0") & " files from " &
strPath _
& IIf(Len(Trim(strFileSpec)) > 0, " for file specification --> " &
strFileSpec, "") _
& vbCrLf & vbCrLf & mMsg, , "Done"

Exit_Handler:
SysCmd acSysCmdClearStatus
'--------

Exit Function

Err_Handler:
MsgBox "Error " & err.Number & ": " & err.DESCRIPTION, , "ERROR"

'remove next line after debugged -- added by Crystal
Stop: Resume 'added by Crystal

Resume Exit_Handler
End Function

Private Function FillDirToTable(colDirList As Collection, ByVal strFolder As
String, strFileName As String, strFileSpec As String, bIncludeSubfolders As
Boolean)
'Build up a list of files, and then add add to this list, any additional
folders
On Error GoTo Err_Handler

Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
Dim strSQL As String

'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
If gCount = 50 Then GoTo Err_Handler
gCount = gCount + 1
SysCmd acSysCmdSetStatus, gCount
If InStr(1, strTemp, strFileName) > 0 Then
strSQL = "INSERT INTO tblFiles (FName, FPath) SELECT """ &
strTemp & """, """ & strFolder & """;"
MsgBox strSQL
CurrentDb.Execute strSQL
End If
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop

If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDirToTable(colDirList, strFolder, strFileName,
strFileSpec, True)
Next vFolderName
End If

Exit_Handler:

Exit Function

Err_Handler:
strSQL = "INSERT INTO tblFiles " & " (FName, FPath) " & " SELECT "" ~~~
ERROR ~~~""" & ", """ & strFolder & """;"
CurrentDb.Execute strSQL

Resume Exit_Handler
End Function

Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function


notice my change around the:

Do While strTemp <> vbNullString
If gCount = 50 Then GoTo Err_Handler
gCount = gCount + 1
SysCmd acSysCmdSetStatus, gCount
If InStr(1, strTemp, strFileName) > 0 Then
strSQL = "INSERT INTO tblFiles (FName, FPath) SELECT """ &
strTemp & """, """ & strFolder & """;"
MsgBox strSQL
CurrentDb.Execute strSQL
End If
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop

when i run the code it loops through and over 9080 records created later it
still hasnt popped out of the loops and finished writing to the table.

anyone know why?
 
Hello All

Actually i found it.

'list files to tables
'http://allenbrowne.com/ser-59alt.html
Dim gCount As Long ' added by Crystal

'crystal modified parameter specification for strFileSpec by adding default
value
Public Function ListFilesToTable(strPath As String, Optional
strSearchFileName As String, Optional strFileSpec As String = "*.*", Optional
bIncludeSubfolders As Boolean)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from
subdirectories of strPath as well.
'Method: FilDir() adds items to a collection, calling itself
recursively for subfolders.

Dim colDirList As New Collection
Dim varitem As Variant
Dim rst As DAO.Recordset

Dim mStartTime As Date
Dim mSeconds As Long
Dim mMin As Long
Dim mMsg As String

mStartTime = Now()
'--------
gCount = 0

Call FillDirToTable(colDirList, strPath, strSearchFileName, strFileSpec,
bIncludeSubfolders)

mSeconds = DateDiff("s", mStartTime, Now())

mMin = mSeconds \ 60
If mMin > 0 Then
mMsg = mMin & " min "
mSeconds = mSeconds - (mMin * 60)
Else
mMsg = ""
End If

mMsg = mMsg & mSeconds & " seconds"

MsgBox "Done adding " & Format(gCount, "#,##0") & " files from " &
strPath _
& IIf(Len(Trim(strFileSpec)) > 0, " for file specification --> " &
strFileSpec, "") _
& vbCrLf & vbCrLf & mMsg, , "Done"

Exit_Handler:
SysCmd acSysCmdClearStatus
'--------

Exit Function

Err_Handler:
MsgBox "Error " & err.Number & ": " & err.DESCRIPTION, , "ERROR"

'remove next line after debugged -- added by Crystal
Stop: Resume 'added by Crystal

Resume Exit_Handler
End Function

Private Function FillDirToTable(colDirList As Collection, ByVal strFolder As
String, strFileName As String, strFileSpec As String, bIncludeSubfolders As
Boolean)
'Build up a list of files, and then add add to this list, any additional
folders
On Error GoTo Err_Handler

Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
Dim strSQL As String

'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
If gCount = 50 Then GoTo Err_Handler
gCount = gCount + 1
SysCmd acSysCmdSetStatus, gCount
If InStr(1, strTemp, strFileName) > 0 Then
strSQL = "INSERT INTO tblFiles (FName, FPath) SELECT """ &
strTemp & """, """ & strFolder & """;"
MsgBox strSQL
CurrentDb.Execute strSQL
End If
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop

If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
this is where the problem is, not sure if i did it or if it was a problem before i copied and pasted<
Click to expand...

For Each vFolderName In colFolders
Call FillDirToTable(colDirList, strFolder & vFolderName,
strFileName,
strFileSpec, True)
Next vFolderName
End If
adding the "& vFolderName" fixed the situation.<
Click to expand...

Exit_Handler:

Exit Function

Err_Handler:
strSQL = "INSERT INTO tblFiles " & " (FName, FPath) " & " SELECT "" ~~~
ERROR ~~~""" & ", """ & strFolder & """;"
CurrentDb.Execute strSQL

Resume Exit_Handler
End Function

Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
 
Back
Top