Hi Jeremy,
I use the following code to create a couple of Access tables. You
could modify it to write to a worksheet or text file, or just export
the Access table.
Function RemoveDoubleQuotes(Original As String) As String
Dim intPosition As Integer
Dim intLength As Integer
Let intLength = Len(Original)
For intPosition = 1 To intLength
If Mid(Original, intPosition, 1) = Chr(34) Then
Let RemoveDoubleQuotes = RemoveDoubleQuotes & Chr(34) &
Chr(34)
Else
Let RemoveDoubleQuotes = RemoveDoubleQuotes & Mid(Original,
intPosition, 1)
End If
Next intPosition
End Function
Sub CreateDictionary()
Dim strTable As String
Dim strTableCreated As String
Dim dblTableRecordCount As Double
Dim strColumn As String
Dim strColumnDescription As String
Dim strSQL As String
Dim intTableCount As Integer
Dim intColumnCount As Integer
Dim intTable As Integer
Dim intColumn As Integer
Dim lngDataType As Long
Dim strDataType As String
Dim strSize As String
Dim dbsCurrent As Database
Dim tdfNew As TableDef
Dim idxNew As Index
Dim rsTable As ADODB.Recordset
On Error GoTo ErrorHandler
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
Rem Delete the tables if they already exist
dbsCurrent.TableDefs.Delete "DataDictionaryTables"
dbsCurrent.TableDefs.Delete "DataDictionaryColumns"
Rem Create a new TableDef object for the Data Dictionary Tables
Table
Set tdfNew = dbsCurrent.CreateTableDef("DataDictionaryTables")
Rem Add fields to table definition
With tdfNew
Rem Create fields and append them to the new TableDef
Rem object. This must be done before appending the
Rem TableDef object to the TableDefs collection
.Fields.Append .CreateField("Table_Name", dbText, 255)
.Fields.Append .CreateField("Created", dbDate)
.Fields.Append .CreateField("NumberOfRecords", dbSingle)
End With
Rem Append the new TableDef object to the database.
dbsCurrent.TableDefs.Append tdfNew
With tdfNew
Rem Create and append a new Index object to the _
Indexes collection of the new TableDef object.
Set idxNew = .CreateIndex("PrimaryKey")
idxNew.Fields.Append idxNew.CreateField("Table_Name")
idxNew.Primary = True
.Indexes.Append idxNew
End With
Rem Create a new TableDef object for the Data Dictionary Columns
Table
Set tdfNew = dbsCurrent.CreateTableDef("DataDictionaryColumns")
Rem Add fields to table definition
With tdfNew
Rem Create fields and append them to the new TableDef _
object. This must be done before appending the _
TableDef object to the TableDefs collection
.Fields.Append .CreateField("Table_Name", dbText, 255)
.Fields.Append .CreateField("Column_Name", dbText, 255)
.Fields.Append .CreateField("Column_Description", dbText, 255)
.Fields("Column_Description").AllowZeroLength = True
.Fields.Append .CreateField("Data_Type", dbText, 75)
.Fields("Data_Type").AllowZeroLength = True
.Fields.Append .CreateField("Data_Size", dbText, 75)
.Fields("Data_Size").AllowZeroLength = True
End With
Rem Append the new TableDef object to the database.
dbsCurrent.TableDefs.Append tdfNew
With tdfNew
Rem Create and append a new Index object to the _
Indexes collection of the new TableDef object.
Set idxNew = .CreateIndex("PrimaryKey")
idxNew.Fields.Append idxNew.CreateField("Table_Name")
idxNew.Fields.Append idxNew.CreateField("Column_Name")
idxNew.Primary = True
.Indexes.Append idxNew
End With
Rem count the tables in the database
intTableCount = CurrentDb.TableDefs.Count - 1
Rem Now loop through all of the tables
For intTable = 0 To intTableCount
Rem first get the table name and add to dictionary
strTable = CurrentDb.TableDefs(intTable).Name
Rem if Table is System Table, then don't include
If (CurrentDb.TableDefs(intTable).Attributes And
dbSystemObject) Then GoTo EndOfTable
Rem if Table is Hidden Table, then don't include
If (Application.GetHiddenAttribute(acTable, strTable)) Then
GoTo EndOfTable
strTableCreated = CurrentDb.TableDefs(intTable).DateCreated
dblTableRecordCount = CurrentDb.TableDefs(intTable).RecordCount
strSQL = "Insert into DataDictionaryTables (Table_Name,
Created,NumberOfRecords) values "
strSQL = strSQL & "(""" & strTable & """,""" &
CDate(strTableCreated) & """," & dblTableRecordCount & ");"
DoCmd.RunSQL (strSQL)
Set rsTable = New ADODB.Recordset
Let strSQL = "SELECT * FROM [" & strTable & "] WHERE 1=0"
rsTable.Open strSQL, "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source= " & CurrentDb.Name
Rem count the columns in this table
intColumnCount = rsTable.Fields.Count - 1
Rem Now loop through the columns
For intColumn = 0 To intColumnCount
Rem get the info for the column and add to dictionary
Let strColumn = rsTable.Fields(intColumn).Name
Let strColumn = RemoveDoubleQuotes(strColumn)
Let strColumnDescription =
CurrentDb.TableDefs(intTable).Fields(intColumn).Properties("Description")
If Not IsNull(strColumnDescription) Then Let
strColumnDescription = RemoveDoubleQuotes(strColumnDescription)
Let strSize = ""
Let lngDataType =
CurrentDb.TableDefs(intTable).Fields(intColumn).Type
Select Case lngDataType
Case dbBigInt
Let strDataType = "Big Integer"
Case dbBinary
Let strDataType = "Binary"
Case dbBoolean
Let strDataType = "Boolean"
Case dbByte
Let strDataType = "Byte"
Case dbChar
Let strDataType = "Character String"
Let strSize = rsTable.Fields(intColumn).DefinedSize
Case dbCurrency
Let strDataType = "Currency"
Case dbDate
Let strDataType = "Date"
Case dbDecimal
Let strDataType = "Decimal"
Let strSize = rsTable.Fields(intColumn).Precision
Let strSize = strSize & "." &
rsTable.Fields(intColumn).NumericScale
Case dbDouble
Let strDataType = "Double"
Case dbFloat
Let strDataType = "Float"
Case dbGUID
Let strDataType = "GUID (Globally Unique
Identifier/Universally Unique Identifier)"
Case dbInteger
Let strDataType = "Integer"
Case dbLong
Let strDataType = "Long"
Case dbLongBinary
Let strDataType = "Long Binary (OLE)"
Case dbMemo
Let strDataType = "Memo"
Case dbNumeric
Let strDataType = "Numeric"
Case dbSingle
Let strDataType = "Single"
Case dbText
Let strDataType = "Text"
Let strSize = rsTable.Fields(intColumn).DefinedSize
Case dbTime
Let strDataType = "Time"
Case dbTimeStamp
Let strDataType = "Time Stamp"
Case dbVarBinary
Let strDataType = "Variable Length Binary"
Case Else
Let strDataType = ""
End Select
Let strSQL = "Insert into DataDictionaryColumns
(Table_Name, Column_Name, Column_Description, Data_Type, Data_Size) "
Let strSQL = strSQL & "values (""" & strTable & """,""" &
strColumn & ""","
If Len(strColumnDescription) > 0 Then
Let strSQL = strSQL & Chr(34) & strColumnDescription &
Chr(34) & "," & Chr(34) & strDataType & Chr(34) & ","
Else
Let strSQL = strSQL & "Null," & Chr(34) & strDataType &
Chr(34) & ","
End If
If Len(strSize) > 0 Then
Let strSQL = strSQL & Chr(34) & strSize & Chr(34) &
");"
Else
Let strSQL = strSQL & "Null);"
End If
DoCmd.RunSQL (strSQL)
Next intColumn
EndOfTable:
Set rsTable = Nothing
Next intTable
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 3270 'Property not Found (Column with no description)
strColumnDescription = ""
Err.Clear
Resume Next
Case 3265 'Object does not exist in this collection (Tried to
delete a table that doesn't exist, so ignore)
Err.Clear
Resume Next
Case Else
MsgBox "An unexpexted error occurred." & vbCrLf & "Error #"
& Err.Number & ": " & Err.Description, vbCritical, "Error Creating Data
Dictionary"
Set rsTable = Nothing
End Select
End Sub
