Publish date: 2003-03-21
Table metadata extract (VB)
'method for extract metadata from table job
'demonstrates how to use Restrictions Columns
'with Connection.OpenSchema method
'it uses methods CreateReport and GetTypeName
Sub Sample10_2()
'adding new workbook
Set work_bk = Application.Workbooks.Add
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
'open connection to employee.gdb
Set con = New ADODB.Connection
con.Open "file name=" & ThisWorkBook.Path & "\employee.ibp"
con.BeginTrans
'extract metadata for table JOB
'use OpenSchema method with Criterias (Array(Restrictions fields))
'columns by table Job (TABLE_NAME Criteria)
Set rs = con.OpenSchema(adSchemaColumns, Array(Empty, Empty, "JOB"))
Call CreateReport(rs, "COLUMNS")
'get domains for job_code column (COLUMN_NAME Criteria)
Set rs = con.OpenSchema(adSchemaColumnsDomainUsage, Array(Empty, Empty, Empty, "JOB_CODE"))
Call CreateReport(rs, "DOMAIN FOR JOB_CODE")
'constraints in table JOB
'primary keys (TABLE_NAME Criteria)
Set rs = con.OpenSchema(adSchemaPrimaryKeys, Array(Empty, Empty, "JOB"))
Call CreateReport(rs, "PRIMARY_KEYS")
'foreign keys (TABLE_NAME Criteria)
Set rs = con.OpenSchema(adSchemaForeignKeys, Array(Empty, Empty, "JOB"))
Call CreateReport(rs, "FOREIGN_KEYS")
'check (TABLE_NAME and CONSTRAINT_TYPE Criteria)
Set rs = con.OpenSchema(adSchemaTableConstraints, Array(Empty, Empty, Empty, Empty, Empty, "JOB", "CHECK"))
Call CreateReport(rs, "CONSTRAINTS")
'uniq constraints not presented in JOB table
'we use project table for get uniq constraint
'(TABLE_NAME and CONSTRAINT_TYPE Criteria)
'(for example uncomment two next instructions)
'Set rs = con.OpenSchema(adSchemaTableConstraints, Array(Empty, Empty, Empty, Empty, Empty, "JOB", "CHECK"))
'Call CreateReport(rs, "UNIQ CONSTRAINTS FOR PROJECT")
'indexes
Set rs = con.OpenSchema(adSchemaIndexes, Array(Empty, Empty, Empty, Empty, "JOB"))
Call CreateReport(rs, "INDEXES FOR JOB TABLE")
con.CommitTrans
con.Close
End Sub
'call OpenSchema and set worksheet name
Private Sub MOpenSchema(MSchemaEnum As SchemaEnum, NameSheet As String, Optional Criteria As Variant = Nothing)
If Not Criteria Is Nothing Then
Set rs = con.OpenSchema(MSchemaEnum, Criteria)
Else
Set rs = con.OpenSchema(MSchemaEnum)
End If
CreateReport rs, NameSheet
End Sub
'place Recordset to the worksheet
Public Sub CreateReport(rs As ADODB.Recordset, NameSheet As String)
'current worksheet
Dim cur_worksheet As Worksheet
Dim i As Integer
'max records per sheet
Dim max_rec As Long
'current row
Dim currow As Long
currow = 1
'find worksheet if exist
For i = 1 To work_bk.Worksheets.Count
If work_bk.Worksheets(i).Name = NameSheet Then
Set cur_worksheet = work_bk.Worksheets(i)
Exit For
End If
Next i
'if wotksheet not exist in workbook adding new worksheet
If cur_worksheet Is Nothing Then
'adding workshet to the end of worksheets list
Set cur_worksheet = work_bk.Worksheets.Add(after:=work_bk.Worksheets(work_bk.Worksheets.Count))
cur_worksheet.Name = NameSheet
Else
'else clear finded worksheet
cur_worksheet.Cells.Clear
End If
With cur_worksheet
Do While Not rs.EOF
'process events
DoEvents
For i = 0 To rs.Fields.Count - 1
'place on error because some OLE DB types not presented in VARIANT
'(for example UI8 type)
On Error Resume Next
.Cells(currow, 3) = rs.Fields(i).Value
.Cells(currow, 1) = rs.Fields(i).Name
'type get from DataTypeEnum
.Cells(currow, 2) = GetTypeName(rs.Fields(i).Type)
'don't print error values
If Err.Description = "" Then
currow = currow + 1
Err.Clear
End If
On Error GoTo 0
Next i
'max record count
max_rec = max_rec + 1
'increment current row
currow = currow + 1
rs.MoveNext
'if MaxRecords <>0 then check for max avalible records per sheet
If MaxRecords > 0 Then
If max_rec >= MaxRecords Then Exit Do
End If
Loop
.Columns.AutoFit
.Rows.AutoFit
End With
End Sub
'return type name by id from DataTypeEnum
Private Function GetTypeName(datatp As Long) As String
Select Case datatp
Case adWChar
GetTypeName = "adWChar"
Case adVarWChar
GetTypeName = "adVarWChar"
Case adVarNumeric
GetTypeName = "adVarNumeric"
Case adVariant
GetTypeName = "adVariant"
Case adVarChar
GetTypeName = "adVarChar"
Case adVarBinary
GetTypeName = "adVarBinary"
Case adUserDefined
GetTypeName = "adUserDefined"
Case adUnsignedTinyInt
GetTypeName = "adUnsignedTinyInt"
Case adUnsignedSmallInt
GetTypeName = "adUnsignedSmallInt"
Case adUnsignedInt
GetTypeName = "adUnsignedInt"
Case adUnsignedBigInt
GetTypeName = "adUnsignedBigInt"
Case adTinyInt
GetTypeName = "adTinyInt"
Case adSmallInt
GetTypeName = "adSmallInt"
Case adSingle
GetTypeName = "adSingle"
Case adPropVariant
GetTypeName = "adPropVariant"
Case adNumeric
GetTypeName = "adNumeric"
Case adLongVarWChar
GetTypeName = "adLongVarWChar"
Case adLongVarChar
GetTypeName = "adLongVarChar"
Case adLongVarBinary
GetTypeName = "adLongVarBinary"
Case adIUnknown
GetTypeName = "adIUnknown"
Case adInteger
GetTypeName = "adInteger"
Case adIDispatch
GetTypeName = "adIDispatch"
Case adGUID
GetTypeName = "adGUID"
Case adFileTime
GetTypeName = "adFileTime"
Case adError
GetTypeName = "adError"
Case adEmpty
GetTypeName = "adEmpty"
Case adDouble
GetTypeName = "adDouble"
Case adDecimal
GetTypeName = "adDecimal"
Case adDBTimeStamp
GetTypeName = "adDBTimeStamp"
Case adDBTime
GetTypeName = "adDBTime"
Case adDBDate
GetTypeName = "adDBDate"
Case adDate
GetTypeName = "adDate"
Case adCurrency
GetTypeName = "adCurrency"
Case adChar
GetTypeName = "adChar"
Case adChapter
GetTypeName = "adChapter"
Case adBSTR
GetTypeName = "adBSTR"
Case adBoolean
GetTypeName = "adBoolean"
Case adBinary
GetTypeName = "adBinary"
Case adBigInt
GetTypeName = "adBigInt"
Case adArray
GetTypeName = "adArray"
Case Else
GetTypeName = "Not a Type"
End Select
End Function