Public Sub CaptureObjects()
'*******************************************
'Name: CaptureObjects (Function)
'Purpose: Creates a table (tblObjects) and populate
' it with information about the tables,
' queries , Forms And Reports
' present in your database.
'WARNING: This code will delete an existing "tblObjects".
'*******************************************
Dim db As Database, xdf As Variant, i As Integer
Dim cnt As Container, rpt As Report, frm As Form
Dim n As Integer, doc As Document, tName As String
Dim Found As Boolean, Test As String, rs As Recordset
Dim strObject As String, j As Integer, k As Integer
Dim strDescription As String, strRecSource As String
Dim strSQL As String, qd As QueryDef, fld As Field
Set db = CurrentDb
tName = "tblObjects"
'Does table "tblObjects" exist? If true, delete it;
Found = False
On Error Resume Next
Test = db.TableDefs(tName).Name
If Err <> 3265 Then
Found = True
docmd.DeleteObject acTable, tName
End If
'Create new tblObjects
db.Execute "CREATE TABLE tblObjects" _
& " (ObjectID LONG, Type TEXT (55)," _
& " Object TEXT (55), Description TEXT (55)," _
& " RecordSource TEXT (55));"
Set rs = db.OpenRecordset(tName)
'Process Tables and Queries
'Fill with table names
Set xdf = db.TableDefs
For k = 0 To xdf.count - 1
If Left(xdf(k).Name, 4) <> "MSys" And Left(xdf(k).Name, 1) <> "~" Then
strDescription = " "
strDescription = xdf(k).Properties("Description")
With rs
.AddNew
!ObjectID = 1
!Type = "Table"
!Object = xdf(k).Name
!Description = strDescription
.Update
End With
End If
Next k
rs.Close
'Process Queries
Call getqueries
strSQL = "INSERT INTO tblObjects ( ObjectID, Type, Description, Object, RecordSource )" _
& " SELECT DISTINCT 2 AS ObjectID, 'Query' AS Type, tblQueries.Description, tblQueries.Object, tblQueries.RecordSource" _
& " FROM tblQueries" _
& " WHERE (((tblQueries.RecordSource)<>''))" _
& " ORDER BY tblQueries.Object;"
db.Execute strSQL
'Process Forms and Reports
For n = 1 To 2
tName = "tblForms" & Format(n)
'Does table "tblForms" exist? If true, delete it;
Found = False
On Error Resume Next
Test = db.TableDefs(tName).Name
If Err <> 3265 Then
Found = True
docmd.DeleteObject acTable, tName
End If
Next n
'Create new tblForms(n)
For n = 1 To 2
strSQL = "CREATE TABLE tblForms" & Format(n) & "(ObjectID LONG, Type TEXT (55), Object TEXT (55), Description TEXT (55), RecordSource TEXT (55));"
db.Execute strSQL
Next n
On Error Resume Next
'Process Forms and Reports
For j = 3 To 4
strObject = IIf(j = 3, "Form", "Report")
Set cnt = IIf(j = 3, db.Containers!Forms, db.Containers!Reports)
k = cnt.Documents.count
For i = 0 To k - 1
Set doc = cnt.Documents(i)
strDescription = ""
strRecSource = ""
strDescription = doc.Properties("Description")
strRecSource = doc.Properties("RecordSource")
' To extract the record source for a form or report, it's necessary
' to open that object momentarily.
' Turn off echo so user can't see forms/reports opening.
docmd.Echo False
If strObject = "Form" Then
docmd.OpenForm doc.Name, acDesign, , , , acHidden
strRecSource = Forms(doc.Name).RecordSource
docmd.Close acForm, doc.Name
Else 'strObject = "Report"
docmd.OpenReport doc.Name, acViewDesign
docmd.Minimize
strRecSource = Reports(doc.Name).RecordSource
docmd.Close acReport, doc.Name
End If
docmd.Echo True
If Left$(strRecSource, 7) <> "SELECT " Then
If strRecSource = "" Then
strRecSource = "None"
Else
strRecSource = strRecSource
End If
Set rs = db.OpenRecordset("tblForms1")
rs.AddNew
rs!ObjectID = j
rs!Type = strObject
rs!Object = doc.Name
rs!Description = strDescription
rs!RecordSource = strRecSource
rs.Update
rs.Close
Else
'strRecSource = "SQL"
tName = "TempFilter"
'Does query "TempFilter" exist? If true, delete it;
Found = False
Test = db.QueryDefs(tName).Name
If Err <> 3265 Then
Found = True
docmd.DeleteObject acQuery, "TempFilter"
End If
strSQL = strRecSource
Set qd = db.CreateQueryDef("TempFilter", strSQL)
db.QueryDefs.Refresh
Set qd = db.QueryDefs("TempFilter")
'strip existing records from tblForms2
strSQL = "Delete * from tblForms2"
db.Execute strSQL
Set rs = db.OpenRecordset("tblForms2")
For k = 0 To qd.Fields.count - 1
If qd.Fields(k).SourceTable <> "" Then
rs.AddNew
rs!ObjectID = j
rs!Type = strObject
rs!Object = doc.Name
rs!Description = strDescription
rs!RecordSource = qd.Fields(k).SourceTable
rs.Update
End If
Next k
End If
Next i
Next j
rs.Close
For n = 1 To 2
strSQL = "INSERT INTO tblObjects ( ObjectID, Type, Object, Description, RecordSource )" _
& " SELECT DISTINCT ObjectID, Type, Object, Description, RecordSource" _
& " FROM tblForms" & Format(n) & ";"
db.Execute strSQL
Next n
db.Close
Set db = Nothing
End Sub
