Recursive Dir - save immediately

[m_harfoot]

Hello Everyone

Using Access 97.

It became apparent during a recent audit that duplicate drawing files
have been saved on the server. We need to identify the duplicates in
order to delete them.

I started with the FillDir code written by Albert D.Kallal but got
overflow Error 6, so had to devise my own solution based on it.

After many wrong variations, I hope I've got something that is OK.
Since I haven't a clue how the recursive dir bit really works(!) may I
ask you to review my code and tell me if it needs repairing or
improvement please.

The database has two tables, Dirs and Files, with a one to many
relationship between them.

The jist is that after the user browses and selects the search
directory (snipped in the code below), the search directory is saved in
the table Dirs. The function getDirectories is called to save the rest
of the directories and sub directories. The last thing is to loop
through the saved Dirs and save the files.

Private Sub cmdBrowse_Click()
On Error GoTo Err_Handler

Dim lngFlags As Long, strReturn As String, str As String, _
rstDirs As DAO.Recordset, rstFiles As DAO.Recordset, strSQL As
String, _
strStartDir As String, strFullPath As String, strTemp As
String, _
lngDirID As Long, lngFileID, bln As Boolean

'<snip the browse for folder code>
If strReturn = "" Then GoTo Exit_Here

strStartDir = strReturn
'must have a trailing slash for the getDirectories function
If Right(strStartDir, 1) <> "\" Then strStartDir = strStartDir &
"\"

strSQL = "SELECT Dirs.* FROM Dirs"
Set rstDirs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset,
dbAppendOnly)

'save the search dir
rstDirs.AddNew
rstDirs!dirID = 1
rstDirs!DirName = strStartDir
rstDirs!isprocessed = -1
rstDirs.Update
rstDirs.Close

'call the function
bln = True
bln = getDirectories(strStartDir, 2)
If bln = False Then
str = "Error while collecting folders."
MsgBox str
GoTo Exit_Here
End If

'loop through the directories and get any files
strSQL = "SELECT Files.* FROM Files"
Set rstFiles = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset,
dbAppendOnly)

strSQL = "SELECT Dirs.* FROM Dirs ORDER BY Dirs.DirID"
Set rstDirs = CurrentDb.OpenRecordset(strSQL)

lngFileID = 1
With rstDirs
.MoveFirst
Do While Not .EOF
strFullPath = !DirName
lngDirID = !dirID
strTemp = Dir(strFullPath)
Do While strTemp <> ""
lngFileID = lngFileID + 1
'<snip code for processing and saving the file>
strTemp = Dir
Loop
.MoveNext
Loop
End With
MsgBox "Finished"

Exit_Here:
On Error Resume Next
rstDirs.Close
Set rstDirs = Nothing
rstFiles.Close
Set rstFiles = Nothing
Exit Sub

Err_Handler:
MsgBox Err.Number & " : " & Err.Description
Resume Exit_Here
End Sub

***************
Private Function getDirectories(strStartDir As String, lngDirID As
Long) As Boolean
On Error GoTo Err_Handler

'called by cmdBrowse_Click
'based on FillDir code written by Albert D.Kallal(MVP) Access

Dim rstDirs As DAO.Recordset, rstProcess As DAO.Recordset, strSQL
As String, _
colFolders As New Collection, varFolderName As Variant, _
varStatusText As Variant, str As String, strTemp As String

getDirectories = True

'this must have a trailing slash
If Right(strStartDir, 1) <> "\" Then strStartDir = strStartDir & "\"

Set rstDirs = CurrentDb.OpenRecordset("Dirs")

' build a list of subDirectories
strTemp = Dir(strStartDir & "*.", vbDirectory)

Do While strTemp <> ""
' Ignore the current and encompassing directories
If (strTemp <> ".") And (strTemp <> "..") Then
On Error Resume Next 'I've found one cause for the error
- foreign characters in the file
If (GetAttr(strStartDir & strTemp) And vbDirectory) =
vbDirectory Then
If Err = 0 Then
lngDirID = lngDirID + 1
'save it
rstDirs.AddNew
rstDirs!dirID = lngDirID
rstDirs!DirName = strStartDir & strTemp & "\"
rstDirs.Update
End If
End If
Err.Clear
On Error GoTo Err_Handler
End If
strTemp = Dir
Loop

' now process each folder (recursion)
strSQL = "SELECT Dirs.DirID, Dirs.DirName, Dirs.dirStripped,
Dirs.isProcessed FROM Dirs " _
& "WHERE (((Dirs.isProcessed) = 0))"

Set rstProcess = CurrentDb.OpenRecordset(strSQL)

If rstProcess.RecordCount > 0 Then
rstProcess.MoveFirst
strStartDir = rstProcess!DirName
rstProcess.Edit
rstProcess!isprocessed = -1
rstProcess.Update
rstProcess.Close
Set rstProcess = Nothing
Call getDirectories(strStartDir, lngDirID)
End If

Exit_Here:
On Error Resume Next
rstDirs.Close
Set rstDirs = Nothing
Exit Function

Err_Handler:
getDirectories = False
'MsgBox Err.Number & " : " & Err.Description
Resume Exit_Here

End Function

Thank you for any help,
Regards Marguerite