ACCESS VBA: I CREATED A FUNCTION EXPORTING TABLE DEFINITIONS DISPLAYED AT DESIGN VIEW IN A TABULAR FORMAT.

 1'******************************************************************************************
 2'*Function      :export data and create excel book
 3'******************************************************************************************
 4Public Sub exportTableDefTablesMain()
 5    
 6    'Const
 7    Const FUNC_NAME As String = "exportTableDefTablesMain"
 8    
 9    'Variable
10    Dim xlApp As Object
11    Dim wb As Object
12    Dim tdf As DAO.TableDef
13    Dim defArr As Variant
14    Dim fstWs As Object
15    Dim ws As Object
16    
17    On Error GoTo ErrorHandler
18    
19    'create new excel app instance and excel-book instance
20    Set xlApp = CreateObject("Excel.Application")
21    With xlApp
22        .Visible = False
23        .DisplayAlerts = False
24        .ScreenUpdating = False
25    End With
26    Set wb = xlApp.Workbooks.Add
27    
28    Set fstWs = wb.Worksheets(1)
29    
30    'create a access table definition information table in separate sheets
31    For Each tdf In CurrentDb.TableDefs
32        Do
33            'do continue if tdf is one of the unnecessary tables such as system table.
34            If Left(tdf.Name, 4) = "Msys" Or Left(tdf.Name, 4) = "Usys" Or Left(tdf.Name, 1) = "~" Then Exit Do
35            
36            'get definition information of the table 
37            defArr = getTableDefArray(tdf)
38            If IsNull(defArr) Then GoTo ExitHandler
39            
40            'create a new sheet
41            Set ws = wb.Worksheets.Add
42            If Not setWSName(ws, tdf.Name) Then Call Err.Raise(1000, "Sheet Name Specification Error", "An error has occurred on sheet name specification.")
43            
44            'write a definition information to Range and auto-adjust the sheet column widths.
45            With ws.Range(ws.cells(1, 1), ws.cells(UBound(defArr) - LBound(defArr) + 1, UBound(defArr, 2) - LBound(defArr, 2) + 1))
46                .Value = defArr
47                .EntireColumn.AutoFit
48            End With
49            
50        Loop While False
51    Next tdf
52    
53    'remove default sheet
54    If wb.Worksheets.Count > 1 Then fstWs.Delete
55    
56    'save
57    wb.saveas Application.CurrentProject.Path & _
58              "\" & _
59              Left( _
60              CurrentProject.Name, _
61              InStrRev(CurrentProject.Name, ".") - 1 _
62              ) & _
63                "_Table_Info_List.xlsx"
64    
65    'Complete
66    MsgBox "Completed", , "INFO"
67    
68    
69ExitHandler:
70    
71    'close connection and instances
72    If Not wb Is Nothing Then wb.Close: Set wb = Nothing
73    If Not xlApp Is Nothing Then xlApp.Quit: Set xlApp = Nothing
74    
75    Set tdf = Nothing
76    Set ws = Nothing
77    Set fstWs = Nothing
78    
79    Exit Sub
80    
81ErrorHandler:
82
83    MsgBox "An error has occurred and the macro will be terminated." & _
84           vbLf & _
85           "Func Name:" & FUNC_NAME & _
86           vbLf & _
87           "Error No." & Err.Number & vbNewLine & _
88           Err.Description, vbCritical, "Error"
89
90        
91    GoTo ExitHandler
92        
93End Sub

  1'******************************************************************************************
  2'*Function      : get definition information of the table 
  3'*                Items: 
  4'*                      Field Name
  5'*                      Data Type
  6'*                      Size
  7'*                      Required or not
  8'*                      Primary key or not
  9'*                      Foreign key or not
 10'*                      Description
 11'*arg(1)        : TableDef instance
 12'*return        : definition information array
 13'******************************************************************************************
 14
 15Public Function getTableDefArray( _
 16       ByVal pTdf As DAO.TableDef _
 17       ) As Variant
 18    
 19    'Const
 20    Const FUNC_NAME As String = "getTableDefArray"
 21    
 22    'Variable
 23    Dim defArr() As Variant
 24    Dim fld As DAO.Field
 25    Dim i As Long
 26    Dim dicPKs As Object
 27    Dim dicFKs As Object
 28    Dim description As String
 29    
 30    On Error GoTo ErrorHandler
 31
 32    getTableDefArray = Null
 33    
 34    'do redimension the array to be (Field Count + 1) rows and 7 columns
 35    ReDim defArr(0 To pTdf.Fields.Count, 0 To 6)
 36    
 37    'setting the header part
 38    defArr(0, 0) = "Field Name"
 39    defArr(0, 1) = "Data Type"
 40    defArr(0, 2) = "Size"
 41    defArr(0, 3) = "Required or not"
 42    defArr(0, 4) = "Primary key or not"
 43    defArr(0, 5) = "Foreign key or not"
 44    defArr(0, 6) = "Description"
 45    
 46    'get a dictionary containing all primary key field names
 47    Set dicPKs = getPKs(pTdf)
 48    If dicPKs Is Nothing Then GoTo ExitHandler
 49    
 50    'get a dictionary containing all foreign key field names
 51    Set dicFKs = getFKs(pTdf)
 52    If dicFKs Is Nothing Then GoTo ExitHandler
 53    
 54    For i = 1 To pTdf.Fields.Count
 55        Set fld = pTdf.Fields(i - 1)
 56        'Field Name
 57        defArr(i, 0) = fld.Name
 58        'Data Type
 59        defArr(i, 1) = getFieldTypeString(fld.Type)
 60        'Size
 61        If fld.Type = dbText Then
 62            defArr(i, 2) = fld.Size
 63        Else
 64            defArr(i, 2) = "-"
 65        End If
 66        'Required or not
 67        If fld.Required Then defArr(i, 3) = ChrW("&H" & 2714)
 68        'Primary key or not ◆note1
 69        If dicPKs.Exists(fld.Name) Then defArr(i, 4) = ChrW("&H" & 2714)
 70        'Foreign key or not ◆note1
 71        If dicFKs.Exists(fld.Name) Then defArr(i, 5) = ChrW("&H" & 2714)
 72        'Description
 73        On Error Resume Next
 74        description = fld.Properties("Description")
 75        On Error GoTo ErrorHandler
 76        defArr(i, 6) = description
 77    Next i
 78
 79
 80    getTableDefArray = defArr
 81    
 82ExitHandler:
 83    
 84    Set fld = Nothing
 85    Set dicFKs = Nothing
 86    Set dicPKs = Nothing
 87    
 88    Exit Function
 89    
 90ErrorHandler:
 91
 92    MsgBox "An error has occurred and the macro will be terminated." & _
 93           vbLf & _
 94           "Func Name:" & FUNC_NAME & _
 95           vbLf & _
 96           "Error No." & Err.Number & vbNewLine & _
 97           Err.Description, vbCritical, "Error"
 98
 99    GoTo ExitHandler
100        
101End Function

 1'******************************************************************************************
 2'*Function      : get field type string of argument field
 3'*arg(1)        : field type number
 4'*return        : field data string
 5'******************************************************************************************
 6Public Function getFieldTypeString(ByVal pFldTyepNum As Long) As String
 7    
 8    'Const
 9    Const FUNC_NAME As String = "getFieldTypeString"
10    
11    'Variable
12    Dim strType As String
13    
14    On Error GoTo ErrorHandler
15
16    strType = ""
17    
18
19    Select Case pFldTyepNum
20    Case dbBoolean
21        strType = "Bool"
22    Case dbByte
23        strType = "Byte"
24    Case dbInteger
25        strType = "Integer"
26    Case dbLong
27        strType = "Long Integer"
28    Case dbSingle
29        strType = "Single Number"
30    Case dbDouble
31        strType = "Double Number"
32    Case dbCurrency
33        strType = "Currency"
34    Case dbDate
35        strType = "Date"
36    Case dbText
37        strType = "short Text"
38    Case dbLongBinary
39        strType = "OLE Object Type"
40    Case dbMemo
41        strType = "long text"
42    End Select
43
44    getFieldTypeString = strType
45    
46ExitHandler:
47
48    Exit Function
49    
50ErrorHandler:
51
52    MsgBox "An error has occurred and the macro will be terminated." & _
53           vbLf & _
54           "Func Name:" & FUNC_NAME & _
55           vbLf & _
56           "Error No." & Err.Number & vbNewLine & _
57           Err.Description, vbCritical, "Error"
58
59        
60    GoTo ExitHandler
61        
62End Function

 1'******************************************************************************************
 2'*Function      : get field strings of primary keys
 3'*arg(1)        : TableDef instance
 4'*return        : Dictionary containing PK info
 5'******************************************************************************************
 6
 7Public Function getPKs(ByVal pTdf As DAO.TableDef) As Object
 8    
 9    'Const
10    Const FUNC_NAME As String = "getPKs"
11    
12    'Variable
13    Dim idx As DAO.Index
14    Dim fld As DAO.Field
15    Dim dic As Object
16    
17    On Error GoTo ErrorHandler
18
19    Set getPKs = Nothing
20    Set dic = CreateObject("Scripting.Dictionary")
21    
22    
23    'check if Primary property is true
24    For Each idx In pTdf.Indexes
25        If idx.Primary = True Then
26            For Each fld In idx.Fields
27                dic.Add fld.Name, True
28            Next
29        End If
30    Next
31
32    'Return
33    Set getPKs = dic
34    
35ExitHandler:
36
37    Set dic = Nothing
38
39    Exit Function
40    
41ErrorHandler:
42
43    MsgBox "An error has occurred and the macro will be terminated." & _
44           vbLf & _
45           "Func Name:" & FUNC_NAME & _
46           vbLf & _
47           "Error No." & Err.Number & vbNewLine & _
48           Err.Description, vbCritical, "Error"
49
50    GoTo ExitHandler
51        
52End Function

 1'******************************************************************************************
 2'*Function      : get field strings of foreign keys
 3'*arg(1)        : TableDef instance
 4'*return        : Dictionary containing PK info
 5'******************************************************************************************
 6Public Function getFKs(ByVal pTdf As DAO.TableDef) As Object
 7    
 8    'Const
 9    Const FUNC_NAME As String = "getFKs"
10    
11    'Variable
12    Dim rsRelation As DAO.Recordset
13    Dim dic As Object
14    
15    On Error GoTo ErrorHandler
16
17    Set getFKs = Nothing
18    Set dic = CreateObject("Scripting.Dictionary")
19    
20    'access MSysRelationships system table
21    Set rsRelation = CurrentDb.OpenRecordset( _
22                     "SELECT szColumn FROM MSysRelationships WHERE szObject =" & _
23                     " " & _
24                     "'" & _
25                     pTdf.Name & _
26                     "'" & _
27                     ";" _
28                     )
29    
30    With rsRelation
31        If .EOF Then Set getFKs = dic: GoTo ExitHandler
32        .MoveFirst
33        Do Until .EOF
34            dic.Add .Fields("szColumn").Value, True
35            .MoveNext
36        Loop
37    End With
38    
39    'Return
40    Set getFKs = dic
41    
42ExitHandler:
43    
44    If Not rsRelation Is Nothing Then rsRelation.Close: Set rsRelation = Nothing
45        
46    Exit Function
47    
48ErrorHandler:
49
50    MsgBox "An error has occurred and the macro will be terminated." & _
51           vbLf & _
52           "Func Name:" & FUNC_NAME & _
53           vbLf & _
54           "Error No." & Err.Number & vbNewLine & _
55           Err.Description, vbCritical, "Error"
56        
57    GoTo ExitHandler
58        
59End Function

 1'******************************************************************************************
 2'*Function      : set worksheet Name to argument sheet
 3'*arg(1)        : excel worksheet instance
 4'*arg(2)        : the name set
 5'*return        : True > normal termination; False > abnormal termination
 6'******************************************************************************************
 7Public Function setWSName( _
 8       ByVal ws As Object, _
 9       ByVal newName As String _
10       ) As Boolean
11    
12    'Const
13    Const FUNC_NAME As String = "setWSName"
14    
15    'Variable
16    
17    On Error GoTo ErrorHandler
18
19    setWSName = False
20    
21    ws.Name = newName
22
23    setWSName = True
24    
25ExitHandler:
26
27    Exit Function
28    
29ErrorHandler:
30
31    'escaping route: if the name includes some charactors not allowed to use to sheet name
32    ws.Name = "Table_" & ws.Parent.Worksheets.Count & "_" & Format(Now, "yyyymmddhhnnss")
33
34    setWSName = True
35    GoTo ExitHandler
36        
37End Function