Here is something that may get you started.
Option Compare Database
Option Explicit
Public Function fBuildDataDictionary()
' Given table tbl_DbDictionary with
'Fields:ItemID Autonumber; SortOrder Number Long
'TableName Text 25; FieldName Text 25
'PrimaryKey Text 25 ; DataType Text 25;
'FieldSize Text 25; Field Description Text 255
' Fill table with information from the properties of the fields
Dim dbAny As DAO.Database
Dim tblAny As DAO.TableDef
Dim fldAny As DAO.Field
Dim strTableName As String, strTableDescription As String
Dim strSQL As String
Dim rstAny As DAO.Recordset
Dim intOrder As Integer
On Error GoTo fBuildDataDictionary_Err
Set dbAny = CurrentDb()
'Clear tbl_DbDictionary
strSQL = "DELETE * FROM tbl_DbDictionary"
dbAny.Execute strSQL, dbFailOnError
Set rstAny = dbAny.OpenRecordset("tbl_DbDictionary")
For Each tblAny In dbAny.TableDefs
strTableName = tblAny.name
'grab the table description if available
'strTableDescription = tblAny.Properties("Description")
If InStr(1, strTableName, "Msys", vbTextCompare) = 0 _
And InStr(1, strTableName, "~") = 0 _
And InStr(1, strTableName, "src_") <> 1 _
And InStr(1, strTableName, "zzz") <> 1 _
And strTableName <> "tbl_DbDictionary" _
Then
For Each fldAny In tblAny.Fields
With rstAny
.AddNew
intOrder = intOrder + 1
!SortOrder = intOrder 'fldAny.OrdinalPosition + 1
!TableName = strTableName
!FieldName = fldAny.name
!DataType = fGetFieldTypeName(fldAny.Type)
If !DataType = "Memo" Then
'Memo fields use a 12-byte pointer
'OLE may also use 12-byte pointers - need to check.
!FieldSize = 12
Else
!FieldSize = fldAny.Size
End If
'=======================================================================
' Added additional data to table
'=======================================================================
If Len(fldAny.DefaultValue) > 0 Then
!DefaultValue = fldAny.DefaultValue
End If
If Len(fldAny.ValidationRule) > 0 Then
!ValidationRule = fldAny.ValidationRule
End If
If Len(fldAny.ValidationText) > 0 Then
!ValidationText = fldAny.ValidationText
End If
If fldAny.Required = True Then
!RequiredField = "Required"
Else
!RequiredField = Null
End If
'=======================================================================
'Autoincrement field is primary key in my databases
If fldAny.Attributes And dbAutoIncrField Then
!PrimaryKey = "True"
End If
.Update
End With
Next fldAny
End If
strTableDescription = vbNullString
Next tblAny
sGetFieldDescriptions
MsgBox "Finished building table - tbl_DbDictionary"
fBuildDataDictionary = True
Exit Function
fBuildDataDictionary_Err:
Select Case Err.Number
Case 3270, 3265
If Err.Number = 3270 Then Debug.Print Err.Number & " " &
Err.Description
'3265 = item not found in this collection
Resume Next
Case 3078 'No such table
'if table does not exist then build it
strSQL = "Create Table tbl_DbDictionary " & _
" (ItemID Counter Constraint PK_ItemID Primary Key" & _
", SortOrder Long, TableName Text(64)" & _
", FieldName Text(64), DateType Text(200)" & _
", FieldSize Text(20), FieldDescription Text(255)" & _
", DefaultValue Text(255), ValidationRule Memo" & _
", Validation Text(255), RequiredField Text(10) )"
dbAny.Execute strSQL, dbFailOnError
dbAny.TableDefs.Refresh
Resume Next
Case Else
MsgBox Err.Number & ": " & Err.Description, , "ERROR:
fBuildDataDictionary"
End Select
End Function
Private Function fGetFieldTypeName(fldAnyType) As String
Dim strAny As String
Select Case fldAnyType
Case dbBigInt
strAny = "Big Integer"
Case dbBinary
strAny = "Binary"
Case dbBoolean
strAny = "Boolean"
Case dbByte
strAny = "Byte"
Case dbChar
strAny = "Char"
Case dbCurrency
strAny = "Number (Currency)"
Case dbDate
strAny = "Date/Time"
Case dbDecimal
strAny = "Decimal"
Case dbDouble
strAny = "Number (Long)"
Case dbFloat
strAny = "Number (Float)"
Case dbGUID
strAny = "GUID"
Case dbInteger
strAny = "Number (Integer)"
Case dbLong
strAny = "Number (Long)"
Case dbLongBinary
strAny = "Long Binary (OLE Object)"
Case dbMemo
strAny = "Memo"
Case dbNumeric
strAny = "Numeric"
Case dbSingle
strAny = "Number (Single)"
Case dbText
strAny = "Text"
Case dbTime
strAny = "Time"
Case dbTimeStamp
strAny = "Time Stamp"
Case dbVarBinary
strAny = "VarBinary"
Case Else
strAny = "Unknown Type"
End Select
fGetFieldTypeName = strAny
End Function
Private Sub sGetFieldDescriptions()
'Loop through all the tables and fields in data table
'Collect the field descriptions
Dim dbAny As DAO.Database
Dim rstDictionary As DAO.Recordset
Dim tblAny As DAO.TableDef
Dim strTable As String, strTablePrior As String, strFieldname As String
On Error GoTo sGetFieldDescriptions_Error
Set dbAny = CurrentDb()
Set rstDictionary = dbAny.OpenRecordset("tbl_DbDictionary")
With rstDictionary
strTablePrior = ""
While Not .EOF
strFieldname = !fldName
strTable = !tblName
If strTablePrior <> strTable Then
Set tblAny = dbAny.TableDefs(strTable)
End If
.Edit
!FieldDescription =
tblAny.Fields(strFieldname).Properties("Description")
.Update
strTablePrior = !tblName
.MoveNext
Wend
End With
Exit Sub
sGetFieldDescriptions_Error:
Select Case Err.Number
Case 3270, 3265
Resume Next
Case Else
MsgBox Err.Number & ": " & Err.Description, , "sGetFieldDescriptions"
End Select
End Sub
Public Function fGetTableDescription(strTableName As String) As String
Dim dbAny As DAO.Database
Dim strTableDescription As String
On Error GoTo fGetTableDescription_Error
Set dbAny = CurrentDb()
strTableDescription =
dbAny.TableDefs(strTableName).Properties("Description")
fGetTableDescription_Exit:
Set dbAny = Nothing
fGetTableDescription = strTableDescription
Exit Function
fGetTableDescription_Error:
Select Case Err.Number
Case 3270, 3265
strTableDescription = vbNullString
Resume fGetTableDescription_Exit
Case Else
MsgBox Err.Number & ": " & Err.Description, , "ERROR:
fGetTableDescription"
End Select
End Function
