I want to extract all the fields associated to my tables in my access database, to get an inventory of all the data objects. This has to populate a form I've created. I've copied an extract of code to determine whether an object in the database is a query or a table and I would like to alter this, if possible.
Any help will be appreciated
Option Compare Database
Option Explicit
Private Sub AddInventory(strContainer As String)
Dim con As DAO.Container
Dim db As DAO.Database
Dim doc As DAO.Document
Dim rst As DAO.Recordset
Dim intI As Integer
Dim strType As String
Dim varRetval As Variant
On Error GoTo HandleErr
' You could easily modify this, using the
' OpenDatabase() function, to work on any database,
' not just the current one.
varRetval = SysCmd(acSysCmdSetStatus, _
"Retrieving " & strContainer & " container information...")
Set db = CurrentDb
Set con = db.Containers(strContainer)
Set rst = db.OpenRecordset("zstblInventory")
For Each doc In con.Documents
If Not IsTemp(doc.Name) Then
' Handle the special queries case.
' Tables and queries are lumped together
' in the Tables container.
If strContainer = "Tables" Then
If IsTable(doc.Name) Then
strType = "Tables"
Else
strType = "Queries"
End If
Else
strType = strContainer
End If
rst.AddNew
rst("Container") = strType
rst("Owner") = doc.Owner
rst("Name") = doc.Name
rst("DateCreated") = doc.DateCreated
rst("LastUpdated") = doc.LastUpdated
rst.Update
End If
Next doc
ExitHere:
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
Exit Sub
HandleErr:
MsgBox Err.Number & ": " & Err.Description, , _
"AddInventory"
Resume ExitHere
End Sub
Private Sub RebuildInventory()
On Error GoTo HandleErr
DoCmd.Hourglass True
Me.lstInventory.RowSource = ""
Call CreateInventory
Me.lstInventory.RowSource = "SELECT ID, Container, Name, " & _
"Format([DateCreated],'mm/dd/yy (h:nn am/pm)') AS [Creation Date], " & _
"Format([lastUpdated],'mm/dd/yy (h:nn am/pm)') AS [Last Updated], " & _
"Owner FROM zstblInventory ORDER BY Container, Name;"
ExitHere:
DoCmd.Hourglass False
Exit Sub
HandleErr:
Resume ExitHere
End Sub
Private Sub CreateInventory()
If (CreateTable()) Then
' These routines use the status line,
' so clear it once everyone's done.
Call AddInventory("Tables")
Call AddInventory("Forms")
Call AddInventory("Reports")
Call AddInventory("Scripts")
Call AddInventory("Modules")
Call AddInventory("Relationships")
' Clear out the status bar.
Call SysCmd(acSysCmdClearStatus)
Else
MsgBox "Unable to create zstblInventory."
End If
End Sub
Private Function CreateTable() As Boolean
' Return True on success, False otherwise
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Dim strSQL As String
On Error GoTo HandleErr
Set db = CurrentDb()
db.Execute "DROP TABLE zstblInventory"
' Create zstblInventory
strSQL = "CREATE TABLE zstblInventory (Name Text (255), " & _
"Container Text (50), DateCreated DateTime, " & _
"LastUpdated DateTime, Owner Text (50), " & _
"ID AutoIncrement Constraint PrimaryKey PRIMARY KEY)"
db.Execute strSQL
' If you got here, you succeeded!
db.TableDefs.Refresh
CreateTable = True
ExitHere:
Exit Function
HandleErr:
Select Case Err
Case 3376, 3011 ' Table or Object not found
Resume Next
Case Else
CreateTable = False
End Select
Resume ExitHere
End Function
Private Function IsTable(ByVal strName As String)
Dim tdf As DAO.TableDef
Dim db As DAO.Database
On Error Resume Next
' Normally, in a function like this,
' you would need to refresh the tabledefs
' collection for each call to the function.
' Since this slows down the function
' by a very large measure, this time,
' just Refresh the collection the first
' time, before you call this function.
Set db = CurrentDb()
' See CreateTable().
'db.Tabledefs.Refresh
Set tdf = db.TableDefs(strName)
IsTable = (Err.Number = 0)
Err.Clear
End Function
Private Function IsTemp(ByVal strName As String)
IsTemp = Left(strName, 7) = "~TMPCLP"
End Function
Private Sub cmdCreateInventory_Click()
Call RebuildInventory
End Sub
Private Sub Detail0_Click()
End Sub
Private Sub Form_Open(Cancel As Integer)
Call RebuildInventory
End Sub
