'---------------------------------------------------------------------------------------
' Module : modGetFieldInfo
' Author : Don Leverton
' Modified sample code from 2 different sources
' raskew - ***** t=99194
' Allen Browne - many thanks on many occasions! ****allenbrownedotcomslashfunc-06dothtml****
' Date : 9/13/2016
' Purpose : ' Loops through all local tables in the DB and gathers all field names, types, sizes and descriptions ...
' : ' Then writes the resulting info to a table, which can then be used for a report.
'---------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
Function TableInfo()
On Error GoTo TableInfoErr
' Credits for this concept and code excerpts are in the module header.
' Purpose: Record the field names, types, sizes and descriptions for every table in the current DB.
' then write this info to records in "tblFields"
Dim MyDB As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim rst As DAO.Recordset
Dim MyTable As String
Set MyDB = CurrentDb()
Dim MyTest As String
'Does table "tblFields" exist?
MyTest = MyDB.TableDefs("tblFields").Name
' If "tblfields" DOES NOT exist it will throw error #3265, which is trapped in the error handler below,
' and the code will resume at the "Create Table:" line label.
'If "tblfields" DOES exist, delete and re-create it.
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "tblFields"
DoCmd.SetWarnings True
CreateTable:
'Create new "tblFields"
MyDB.Execute "CREATE TABLE tblFields(Object TEXT (55), FieldName TEXT (55), FieldType TEXT (20), FieldSize Long, FieldAttributes Long, FldDescription TEXT (20));"
MyDB.TableDefs.Refresh
Application.RefreshDatabaseWindow
'Now that we know we have a fresh, blank copy of the table, we can open it's Recordset and populate it.
Set rst = MyDB.OpenRecordset("tblFields", dbOpenDynaset)
For Each tdf In MyDB.TableDefs
MyTable = tdf.Name
If Left(MyTable, 4) <> "MSys" And Left(MyTable, 1) <> "~" And MyTable <> "tblFields" Then
With rst
For Each fld In tdf.Fields
.AddNew
!Object = tdf.Name
!FieldName = fld.Name
!FieldType = FieldTypeName(fld)
!FieldSize = fld.Size
!FieldAttributes = fld.Attributes
!FldDescription = GetDescrip(fld)
.Update
Next fld
End With
End If
Next tdf
TableInfoExit:
Set rst = Nothing
Set MyDB = Nothing
Exit Function
TableInfoErr:
Select Case Err
Case 3265 'If this error is thrown, it means that "tblFields" does not exist.
GoTo CreateTable
Case Else
Debug.Print "TableInfo() Error " & Err & ": " & Error
End Select
Resume TableInfoExit
End Function
Function GetDescrip(obj As Object) As String
On Error Resume Next
GetDescrip = obj.Properties("Description")
End Function
Function FieldTypeName(fld As DAO.Field) As String
'Purpose: Converts the numeric results of DAO Field.Type to text.
Dim strReturn As String 'Name to return
Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.
Case dbBoolean: strReturn = "Yes/No" ' 1
Case dbByte: strReturn = "Byte" ' 2
Case dbInteger: strReturn = "Integer" ' 3
Case dbLong ' 4
If (fld.Attributes And dbAutoIncrField) = 0& Then
strReturn = "Long Integer"
Else
strReturn = "AutoNumber"
End If
Case dbCurrency: strReturn = "Currency" ' 5
Case dbSingle: strReturn = "Single" ' 6
Case dbDouble: strReturn = "Double" ' 7
Case dbDate: strReturn = "Date/Time" ' 8
Case dbBinary: strReturn = "Binary" ' 9 (no interface)
Case dbText '10
If (fld.Attributes And dbFixedField) = 0& Then
strReturn = "Text"
Else
strReturn = "Text (fixed width)" '(no interface)
End If
Case dbLongBinary: strReturn = "OLE Object" '11
Case dbMemo '12
If (fld.Attributes And dbHyperlinkField) = 0& Then
strReturn = "Memo"
Else
strReturn = "Hyperlink"
End If
Case dbGUID: strReturn = "GUID" '15
'Attached tables only: cannot create these in JET.
Case dbBigInt: strReturn = "Big Integer" '16
Case dbVarBinary: strReturn = "VarBinary" '17
Case dbChar: strReturn = "Char" '18
Case dbNumeric: strReturn = "Numeric" '19
Case dbDecimal: strReturn = "Decimal" '20
Case dbFloat: strReturn = "Float" '21
Case dbTime: strReturn = "Time" '22
Case dbTimeStamp: strReturn = "Time Stamp" '23
'Constants for complex types don't work prior to Access 2007 and later.
Case 101&: strReturn = "Attachment" 'dbAttachment
Case 102&: strReturn = "Complex Byte" 'dbComplexByte
Case 103&: strReturn = "Complex Integer" 'dbComplexInteger
Case 104&: strReturn = "Complex Long" 'dbComplexLong
Case 105&: strReturn = "Complex Single" 'dbComplexSingle
Case 106&: strReturn = "Complex Double" 'dbComplexDouble
Case 107&: strReturn = "Complex GUID" 'dbComplexGUID
Case 108&: strReturn = "Complex Decimal" 'dbComplexDecimal
Case 109&: strReturn = "Complex Text" 'dbComplexText
Case Else: strReturn = "Field type " & fld.Type & " unknown"
End Select
FieldTypeName = strReturn
End Function