DAO Access Corruption Finder

				
--**************************************
-- Name: DAO Access Corruption Finder
-- Description:Recently, the IT department found an MSAccess 97 database that would not Compact. I was assigned the task to find out why.
-- By: Rob Waibel
--
-- Inputs:TableName of the table you fear is at fault
--
-- Returns:Table with the Name of the Table in error, the field with the corruption and the Primary Key of teh affected record
--
-- Assumes:This code has only been tested in MSAccess 97.
--
-- Side Effects:none, it only LOOKS!
--
--This code is copyrighted and has-- limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=927&lngWId=5--for details.--**************************************

Public Function TouchAll(sTableName As String)
Dim RS As DAO.Recordset, T As DAO.TableDef
On Error GoTo TableExists
'create tempTable
Set T = CurrentDb.CreateTableDef("ErrorRecords" & sTableName)
With T
.Fields.Append .CreateField("TableName", dbText, 32)
.Fields.Append .CreateField("FieldName", dbText, 32)
.Fields.Append .CreateField("RecNum", dbText, 32)
End With
CurrentDb.TableDefs.Append T
Set T = Nothing
Dim X As Long
Dim aValue As Variant
On Error GoTo ErrorWithRecord
Set RS = CurrentDb.OpenRecordset("Select * From " & sTableName)
While Not RS.EOF
For X = 0 To RS.Fields.Count() - 1
aValue = RS(X)
Next X
RS.MoveNext
Wend
RS.Close
Exit Function
ErrorWithRecord:
CurrentDb.Execute ("insert into ErrorRecords Values ('" & sTableName & "', '" & RS.Fields(X).Name & "', '" & RS(0) & "')")
Resume Next
Stop
TableExists:
CurrentDb.TableDefs.Delete "ErrorRecords"
Resume 0
End Function