[Access VBA] デザインビューのテーブル定義を表形式でエクスポートする関数を作成した

 1'******************************************************************************************
 2'*関数名    ：exportTableDefTablesMain
 3'*機能      ：テーブル定義情報テーブルを作成
 4'*引数(1)   ：
 5'******************************************************************************************
 6Public Sub exportTableDefTablesMain()
 7    
 8    '定数
 9    Const FUNC_NAME As String = "exportTableDefTablesMain"
10    
11    '変数
12    Dim xlApp As Object
13    Dim wb As Object
14    Dim tdf As DAO.TableDef
15    Dim defArr As Variant
16    Dim fstWs As Object
17    Dim ws As Object
18    
19    On Error GoTo ErrorHandler
20    
21    'エクセルブック開始
22    Set xlApp = CreateObject("Excel.Application")
23    With xlApp
24        .Visible = False
25        .DisplayAlerts = False
26        .ScreenUpdating = False
27    End With
28    Set wb = xlApp.Workbooks.Add
29    
30    '初期シート
31    Set fstWs = wb.Worksheets(1)
32    
33    'テーブルごとに別シートにテーブル定義情報テーブルを作成
34    For Each tdf In CurrentDb.TableDefs
35        Do
36            'システムテーブル等出力の必要のないテーブルの場合はcontinue
37            If Left(tdf.Name, 4) = "Msys" Or Left(tdf.Name, 4) = "Usys" Or Left(tdf.Name, 1) = "~" Then Exit Do
38            
39            'テーブルの定義情報配列を取得
40            defArr = getTableDefArray(tdf)
41            If IsNull(defArr) Then GoTo ExitHandler
42            
43            'ブックで新規シートを作成
44            Set ws = wb.Worksheets.Add
45            If Not setWSName(ws, tdf.Name) Then Call Err.Raise(1000, "シート名指定エラー", "シート名指定の際にエラーが発生しました。")
46            
47            '定義情報配列を記入し、列幅調整
48            With ws.Range(ws.cells(1, 1), ws.cells(UBound(defArr) - LBound(defArr) + 1, UBound(defArr, 2) - LBound(defArr, 2) + 1))
49                .Value = defArr
50                .EntireColumn.AutoFit
51            End With
52            
53        Loop While False
54    Next tdf
55    
56    '初期シートの削除
57    If wb.Worksheets.Count > 1 Then fstWs.Delete
58    
59    'ブック保存
60    wb.saveas Application.CurrentProject.Path & _
61              "\" & _
62              Left( _
63              CurrentProject.Name, _
64              InStrRev(CurrentProject.Name, ".") - 1 _
65              ) & _
66                "_テーブル定義一覧.xlsx"
67    
68    '完了
69    MsgBox "エクスポート完了", , "通知"
70    
71    
72ExitHandler:
73    
74    'クローズ
75    If Not wb Is Nothing Then wb.Close: Set wb = Nothing
76    If Not xlApp Is Nothing Then xlApp.Quit: Set xlApp = Nothing
77    
78    Set tdf = Nothing
79    Set ws = Nothing
80    Set fstWs = Nothing
81    
82    Exit Sub
83    
84ErrorHandler:
85
86    MsgBox "エラーが発生したため、マクロを終了します。" & _
87           vbLf & _
88           "関数名：" & FUNC_NAME & _
89           vbLf & _
90           "エラー番号：" & Err.Number & vbNewLine & _
91           Err.description, vbCritical, "エラー"
92        
93    GoTo ExitHandler
94        
95End Sub

  1'******************************************************************************************
  2'*関数名    ：getTableDefArray
  3'*機能      ：テーブルの定義情報を取得
  4'*            項目：フィールド名
  5'*                  データ型
  6'*                  サイズ
  7'*                  必須項目かどうか
  8'*                  主キー（PK）
  9'*                  外部キー（FK）
 10'*                  説明
 11'*
 12'*引数(1)   ：テーブル定義
 13'*戻り値    ：定義情報配列
 14'******************************************************************************************
 15Public Function getTableDefArray( _
 16       ByVal pTdf As DAO.TableDef _
 17       ) As Variant
 18    
 19    '定数
 20    Const FUNC_NAME As String = "getTableDefArray"
 21    
 22    '変数
 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    '(テーブルのフィールド数 + 1)×7のサイズの配列
 35    ReDim defArr(0 To pTdf.Fields.Count, 0 To 6)
 36    
 37    'ヘッダ設定
 38    defArr(0, 0) = "フィールド名"
 39    defArr(0, 1) = "データ型"
 40    defArr(0, 2) = "サイズ"
 41    defArr(0, 3) = "必須"
 42    defArr(0, 4) = "PK"
 43    defArr(0, 5) = "FK"
 44    defArr(0, 6) = "説明"
 45    
 46    'テーブルのすべての主キーであるフィールド名を辞書として取得
 47    Set dicPKs = getPKs(pTdf)
 48    If dicPKs Is Nothing Then GoTo ExitHandler
 49    
 50    'テーブルのすべての外部キーであるフィールド名を辞書として取得
 51    Set dicFKs = getFKs(pTdf)
 52    If dicFKs Is Nothing Then GoTo ExitHandler
 53    
 54    'フィールドごとに探索
 55    For i = 1 To pTdf.Fields.Count
 56        Set fld = pTdf.Fields(i - 1)
 57        'フィールド名
 58        defArr(i, 0) = fld.Name
 59        'データ型
 60        defArr(i, 1) = getFieldTypeString(fld.Type)
 61        'サイズ
 62        If fld.Type = dbText Then
 63            defArr(i, 2) = fld.Size
 64        Else
 65            defArr(i, 2) = "-"
 66        End If
 67        '必須項目かどうか
 68        If fld.Required Then defArr(i, 3) = "○"
 69        '主キー（PK）かどうか ◆note1
 70        If dicPKs.Exists(fld.Name) Then defArr(i, 4) = "○"
 71        '外部キー（FK）かどうか ◆note1
 72        If dicFKs.Exists(fld.Name) Then defArr(i, 5) = "○"
 73        '説明
 74        On Error Resume Next
 75        description = fld.Properties("Description")
 76        On Error GoTo ErrorHandler
 77        defArr(i, 6) = description
 78    Next i
 79
 80
 81    getTableDefArray = defArr
 82    
 83ExitHandler:
 84    
 85    Set fld = Nothing
 86    Set dicFKs = Nothing
 87    Set dicPKs = Nothing
 88    
 89    Exit Function
 90    
 91ErrorHandler:
 92
 93    MsgBox "エラーが発生したため、マクロを終了します。" & _
 94           vbLf & _
 95           "関数名：" & FUNC_NAME & _
 96           vbLf & _
 97           "エラー番号：" & Err.Number & vbNewLine & _
 98           Err.description, vbCritical, "エラー"
 99        
100    GoTo ExitHandler
101        
102End Function

 1'******************************************************************************************
 2'*関数名    ：getFieldTypeString
 3'*機能      ：フィールドのデータ型文字列を取得
 4'*引数(1)   ：フィールドタイプ
 5'*戻り値    ：フィールドのデータ型文字列
 6'******************************************************************************************
 7Public Function getFieldTypeString(ByVal pFldTyepNum As Long) As String
 8    
 9    '定数
10    Const FUNC_NAME As String = "getFieldTypeString"
11    
12    '変数
13    Dim strType As String
14    
15    On Error GoTo ErrorHandler
16
17    strType = ""
18    
19
20    Select Case pFldTyepNum
21    Case dbBoolean
22        strType = "ブール型"
23    Case dbByte
24        strType = "バイト型"
25    Case dbInteger
26        strType = "整数型"
27    Case dbLong
28        strType = "長整数型"
29    Case dbSingle
30        strType = "単精度浮動小数点型"
31    Case dbDouble
32        strType = "倍精度浮動小数点型"
33    Case dbCurrency
34        strType = "通貨型"
35    Case dbDate
36        strType = "日付/時刻型"
37    Case dbText
38        strType = "テキスト型"
39    Case dbLongBinary
40        strType = "OLEオブジェクト型"
41    Case dbMemo
42        strType = "メモ型"
43    End Select
44
45    getFieldTypeString = strType
46    
47ExitHandler:
48
49    Exit Function
50    
51ErrorHandler:
52
53    MsgBox "エラーが発生したため、マクロを終了します。" & _
54           vbLf & _
55           "関数名：" & FUNC_NAME & _
56           vbLf & _
57           "エラー番号：" & Err.Number & vbNewLine & _
58           Err.description, vbCritical, "エラー"
59        
60    GoTo ExitHandler
61        
62End Function

 1'******************************************************************************************
 2'*関数名    ：getPKs
 3'*機能      ：テーブルの主キーであるフィールド名を辞書として取得
 4'*引数(1)   ：フィールドタイプ
 5'*戻り値    ：辞書
 6'******************************************************************************************
 7Public Function getPKs(ByVal pTdf As DAO.TableDef) As Object
 8    
 9    '定数
10    Const FUNC_NAME As String = "getPKs"
11    
12    '変数
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    'インデックスより探索
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 "エラーが発生したため、マクロを終了します。" & _
44           vbLf & _
45           "関数名：" & FUNC_NAME & _
46           vbLf & _
47           "エラー番号：" & Err.Number & vbNewLine & _
48           Err.description, vbCritical, "エラー"
49        
50    GoTo ExitHandler
51        
52End Function

 1'******************************************************************************************
 2'*関数名    ：getFKs
 3'*機能      ：テーブルの外部キーであるフィールド名を辞書として取得
 4'*引数(1)   ：
 5'*戻り値    ：辞書
 6'******************************************************************************************
 7Public Function getFKs(ByVal pTdf As DAO.TableDef) As Object
 8    
 9    '定数
10    Const FUNC_NAME As String = "getFKs"
11    
12    '変数
13    Dim rsRelation As DAO.Recordset
14    Dim dic As Object
15    
16    On Error GoTo ErrorHandler
17
18    Set getFKs = Nothing
19    Set dic = CreateObject("Scripting.Dictionary")
20    
21    'リレーションテーブルにアクセス
22    Set rsRelation = CurrentDb.OpenRecordset( _
23                     "SELECT szColumn FROM MSysRelationships WHERE szObject =" & _
24                     " " & _
25                     "'" & _
26                     pTdf.Name & _
27                     "'" & _
28                     ";" _
29                     )
30    
31    With rsRelation
32        If .EOF Then Set getFKs = dic: GoTo ExitHandler
33        .MoveFirst
34        Do Until .EOF
35            dic.Add .Fields("szColumn").Value, True
36            .MoveNext
37        Loop
38    End With
39    
40    'Return
41    Set getFKs = dic
42    
43ExitHandler:
44    
45    If Not rsRelation Is Nothing Then rsRelation.Close: Set rsRelation = Nothing
46        
47    Exit Function
48    
49ErrorHandler:
50
51    MsgBox "エラーが発生したため、マクロを終了します。" & _
52           vbLf & _
53           "関数名：" & FUNC_NAME & _
54           vbLf & _
55           "エラー番号：" & Err.Number & vbNewLine & _
56           Err.description, vbCritical, "エラー"
57
58        
59    GoTo ExitHandler
60        
61End Function

 1'******************************************************************************************
 2'*関数名    ：setWSName
 3'*機能      ：エクセルシートの名前をセット
 4'*引数(1)   ：エクセルシート
 5'*引数(2)   ：代入する名前
 6'*戻り値    ：True > 正常終了、False > 異常終了
 7'******************************************************************************************
 8Public Function setWSName( _
 9       ByVal ws As Object, _
10       ByVal newName As String _
11       ) As Boolean
12    
13    '定数
14    Const FUNC_NAME As String = "setWSName"
15    
16    '変数
17    
18    On Error GoTo ErrorHandler
19
20    setWSName = False
21    
22    ws.Name = newName
23
24    setWSName = True
25    
26ExitHandler:
27
28    Exit Function
29    
30ErrorHandler:
31
32    'シート名に使用できない文字であった場合
33    ws.Name = "テーブル_" & ws.Parent.Worksheets.Count & "_" & Format(Now, "yyyymmddhhnnss")
34
35    setWSName = True
36    GoTo ExitHandler
37        
38End Function