Option Compare Database 
Option Explicit 
 
Sub DocumentAll() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Writes object type, name and description of all database
     '               tables, queries, forms and reports to the table "tbl_Documenter"
     '
     ' Assumptions:  Existence of table "tbl_Documenter"
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim db As DAO.Database ' database
    Dim tdf As DAO.TableDef ' all tables
    Dim qdf As DAO.QueryDef ' all queries
    Dim doc As DAO.Document ' all forms/reports
    Dim rec As DAO.Recordset ' table to write descriptions
    Dim prp As Property ' object property
    Dim strSQL As String ' clear existing documenter table
    Dim bytType As Byte ' type of object
     
     
    On Error Goto ErrHandler 
     
     
     ' clear existing documented structure
    strSQL = "DELETE * " & _ 
    "FROM   tbl_Documenter" 
     
    DoCmd.SetWarnings False 
    DoCmd.RunSQL strSQL 
    DoCmd.SetWarnings True 
     
     ' capture all database objects
    Set db = CurrentDb 
    Set rec = db.OpenRecordset("tbl_Documenter", dbOpenDynaset) 
     
     ' tables
    bytType = 1 
    For Each tdf In db.TableDefs 
         ' exclude system tables
        If LCase(Left(tdf.Name, 4)) <> "msys" And _ 
        tdf.Name <> "tbl_Documenter" Then 
            With rec 
                .AddNew 
                !txt_Doc_ObjectType = "Table" 
                !txt_Doc_Name = tdf.Name 
                !txt_Doc_Description = tdf.Properties("Description") 
                .Update 
            End With 
        End If 
    Next tdf 
     
     ' queries
    bytType = 2 
    For Each qdf In db.QueryDefs 
         ' exclude system queries
        If LCase(Left(qdf.Name, 1)) <> "~" Then 
            With rec 
                .AddNew 
                !txt_Doc_ObjectType = "Query" 
                !txt_Doc_Name = qdf.Name 
                !txt_Doc_Description = qdf.Properties("Description") 
                .Update 
            End With 
        End If 
    Next qdf 
     
     ' forms
    bytType = 3 
    With db.Containers!Forms 
        For Each doc In .Documents 
            With rec 
                .AddNew 
                !txt_Doc_ObjectType = "Form" 
                !txt_Doc_Name = doc.Name 
                !txt_Doc_Description = doc.Properties("Description") 
                .Update 
            End With 
        Next doc 
    End With 
     
     ' reports
    bytType = 4 
    With db.Containers!Reports 
        For Each doc In .Documents 
            With rec 
                .AddNew 
                !txt_Doc_ObjectType = "Report" 
                !txt_Doc_Name = doc.Name 
                !txt_Doc_Description = doc.Properties("Description") 
                .Update 
            End With 
        Next doc 
    End With 
     
     
ExitHere: 
    On Error Resume Next 
    qdf.Close 
    rec.Close 
    db.Close 
     
    Set tdf = Nothing 
    Set qdf = Nothing 
    Set doc = Nothing 
    Set prp = Nothing 
    Set rec = Nothing 
    Set db = Nothing 
    Close #1 
    Exit Sub 
     
ErrHandler: 
    If Err.Number = 3270 Then 
         ' property not found - need to create
        Select Case bytType 
        Case 1 ' table
            Set prp = tdf.CreateProperty("Description", dbText) 
            prp.Value = "No Description Set" 
            tdf.Properties.Append prp 
             
        Case 2 ' query
            Set prp = qdf.CreateProperty("Description", dbText) 
            prp.Value = "No Description Set" 
            qdf.Properties.Append prp 
             
        Case 3, 4 ' form/report
            Set prp = doc.CreateProperty("Description", dbText) 
            prp.Value = "No Description Set" 
            doc.Properties.Append prp 
        End Select 
         
        Err.Clear 
        Resume 
         
    Else 
        MsgBox Err.Number & ": " & Err.Description 
        Resume ExitHere 
    End If 
End Sub