Option Compare Database
Option Explicit
Sub DocumentAll()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
Dim doc As DAO.Document
Dim rec As DAO.Recordset
Dim prp As Property
Dim strSQL As String
Dim bytType As Byte
On Error GoTo ErrHandler
strSQL = "DELETE * " & _
"FROM tbl_Documenter"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Set db = CurrentDb
Set rec = db.OpenRecordset("tbl_Documenter", dbOpenDynaset)
bytType = 1
For Each tdf In db.TableDefs
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
bytType = 2
For Each qdf In db.QueryDefs
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
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
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
Select Case bytType
Case 1
Set prp = tdf.CreateProperty("Description", dbText)
prp.Value = "No Description Set"
tdf.Properties.Append prp
Case 2
Set prp = qdf.CreateProperty("Description", dbText)
prp.Value = "No Description Set"
qdf.Properties.Append prp
Case 3, 4
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
|