hi guys,
I found 2 procedures that I combined,
first one lists all accdb files on a certain network drive,
second one lists all the tables in that DB and some info I need (rows, field count, index count).
It worked find on the first network drive, detecting over 80 db's and listing over a 1000 tables without problems.
however on the second drive I think I have some corrupt databases (one of the reasons I am doing this exercice in the first place), and I end up with a 'not responding' message, and the program freezes...
is there a way to detect if a db is corrupt? I really don't want to go through all of the databases (180 on that particular drive).
anyway here's the code I frankensteined together really quickly:
I found 2 procedures that I combined,
first one lists all accdb files on a certain network drive,
second one lists all the tables in that DB and some info I need (rows, field count, index count).
It worked find on the first network drive, detecting over 80 db's and listing over a 1000 tables without problems.
however on the second drive I think I have some corrupt databases (one of the reasons I am doing this exercice in the first place), and I end up with a 'not responding' message, and the program freezes...
is there a way to detect if a db is corrupt? I really don't want to go through all of the databases (180 on that particular drive).
anyway here's the code I frankensteined together really quickly:
Code:
Option Explicit
Private recurseDepth As Integer
Sub FULLLISTER(afs As String)
list_DB (afs)
Dim db As DAO.Database
Dim rst As Recordset
Dim dbv As String
Set db = CurrentDb
db.Execute "DELETE * FROM RESULT_SCAN;"
Set rst = db.OpenRecordset("LIST_DB")
rst.MoveFirst
Do Until rst.EOF
If rst!afs.Value = afs Then
dbv = rst!Path.Value
LoopThroughTables (dbv)
rst.MoveNext
Debug.Print "done: " & dbv
End If
Loop
db.Execute ("AQ_RESULT_SCAN")
Set db = Nothing
Set rst = Nothing
MsgBox "done"
End Sub
Sub list_DB(afs As String)
Dim rootFolder As String
Dim filename As String
Dim resultFiles() As String
Dim i As Integer
Dim db As DAO.Database
Dim rst As Recordset
Set db = CurrentDb
db.Execute "Delete LIST_DB.afs FROM LIST_DB WHERE (((LIST_DB.afs)= '" & afs & "'));"
Set rst = db.OpenRecordset("LIST_DB")
rootFolder = afs
filename = "*.accdb"
If FindFiles(rootFolder, filename, resultFiles) > 0 Then
For i = 1 To UBound(resultFiles)
'Debug.Print Format(i, "00") & ": " & resultFiles(i)
rst.AddNew
rst!Path = resultFiles(i)
rst!afs = afs
rst!sys_date = Int(Now())
rst.Update
Next i
Else
Debug.Print "No files found!"
End If
End Sub
Public Function FindFiles(thisFolder As String, filespec As String, _
ByRef fileList() As String) As Integer
'--- starts in the given folder and checks all files against the filespec.
' the filespec MAY HAVE A WILDCARD specified, so the function returns
' an array of full pathnames (strings) to each file that matches
' Parameters: thisFolder - string containing a full path to the root
' folder for the search
' filespec - string containing a single filename to
' search for, --or--
' string containing a wildcard string of
' files to search for
' (result==>)fileList - an array of strings, each will be a full
' path to a file matching the input filespec
' Returns: (integer) count of the files found that match the filespec
On Error GoTo Error_FindFile
Static fso As Object
Static pathCollection As Collection
Dim fullFilePath As String
Dim oFile As Object
Dim oFolder As Object
Dim oSubfolder As Object
'--- first time through, set up the working objects
If recurseDepth = 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set pathCollection = New Collection
End If
recurseDepth = recurseDepth + 1
'--- focus on the given folder
Set oFolder = fso.GetFolder(thisFolder)
'--- first test if we have permissions to access the folder and
' if there are any files in the folder
On Error Resume Next
If oFolder.Files.Count > 0 Then
If Err.Number = 0 Then
'--- loop through all items in the folder. some are files and
' some are folders -- use recursion to search the subfolders
For Each oFile In oFolder.Files
If oFile.Name Like filespec Then
pathCollection.Add oFolder.Path & "\" & oFile.Name
End If
Next oFile
For Each oSubfolder In oFolder.SubFolders
FindFiles oSubfolder.Path, filespec, fileList
Next oSubfolder
Else
'--- if we get here it's usually a permissions error, so
' just skip this folder
Err.Clear
End If
End If
On Error GoTo Error_FindFile
Exit_FindFile:
recurseDepth = recurseDepth - 1
If (recurseDepth = 0) And (pathCollection.Count > 0) Then
'--- pull the paths out of the collection and make an array, because most
' programs uses arrays more easily
ReDim fileList(1 To pathCollection.Count)
Dim i As Integer
For i = 1 To pathCollection.Count
fileList(i) = pathCollection.Item(i)
Next i
End If
FindFiles = pathCollection.Count
Exit Function
Error_FindFile:
Debug.Print "Error (" & Err.Number & "): " & Err.Description & _
" on " & oSubfolder.Path
GoTo Exit_FindFile
End Function
Public Function LoopThroughTables(dba As Variant)
On Error GoTo Error_Findtable
Dim db As DAO.Database
Dim db2 As DAO.Database
Dim tdf As DAO.TableDef
Set db = CurrentDb
Set db2 = OpenDatabase(dba)
Dim rst2 As Recordset
db.Execute "Delete SCAN_TABLES.path FROM SCAN_TABLES WHERE (((SCAN_TABLES.path)= '" & dba & "'));"
Set rst2 = db.OpenRecordset("SCAN_TABLES")
For Each tdf In db2.TableDefs
' ignore system and temporary tables
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") And tdf.Connect = "" Then
Debug.Print db2.Name; tdf.Name, tdf.RecordCount, tdf.Fields.Count, tdf.Indexes.Count
rst2.AddNew
rst2!Path = db2.Name
rst2!TableName = tdf.Name
rst2!nbr_records = tdf.RecordCount
rst2!nbr_fields = tdf.Fields.Count
rst2!nbr_indexes = tdf.Indexes.Count
rst2!sys_date = Int(Now())
rst2.Update
End If
Next
Set tdf = Nothing
Set db = Nothing
Set rst2 = Nothing
Set db2 = Nothing
Error_Findtable:
Debug.Print "tablefinder Error (" & Err.Number & "): " & Err.Description & _
" on " & dba
Exit Function
End Function
