DBテーブル定義解析

DBのテーブルを読み取ってエクセルに表示します。
サンプルのEXCELファイルをダウンロード

Option Explicit
'
Sub テーブル解析_Click()
    Call db_table_define_read
End Sub
'
Sub db_table_define_read()
On Error GoTo dbError

'必要な参照設定（古いバージョンでも良い）
'Microsoft ADO Ext. 6.0 for DDL and Security
'Microsoft ActiveX Data Objects 6.1 Library
'Microsoft Office xx.0 Access database engine Object Library

    'ADOXもADODBもFieldsが定義順にとれない
    Dim ado_cat     As New ADOX.Catalog
    Dim ado_tbl     As New ADOX.Table
    Dim ado_clm     As New ADOX.Column
    Dim ado_idx     As ADOX.Indexes
  
    Dim ado_con     As New ADODB.Connection
    Dim ado_rst     As New ADODB.Recordset
    Dim ado_fls     As ADODB.Fields
    
    'DAOはFieldsもIndexesもあるがNumericScaleが無い
    Dim dao_dbo     As DAO.Database
    Dim dao_rst     As DAO.Recordset
    Dim dao_fls     As DAO.Fields
    Dim dao_idx     As DAO.Indexes
    
    Dim TargetDB    As String
    Dim TargetTable As String
    Dim Line        As Integer
    Dim i, j, k     As Integer
    Dim TblIdx      As Integer
    Dim Sh          As Worksheet
      
      
    '以降Withでの段下げ省略
    Set Sh = ThisWorkbook.Worksheets("テーブル解析")
    With Sh
    
    TargetDB = Trim(.Range("DbName"))
    TargetTable = Trim(.DropDowns("TblList").List(.DropDowns("TblList").Value))
    
    .Columns("F:K").ColumnWidth = 5
    .Columns("S:X").ColumnWidth = 5
    .Columns("AA:AA").ColumnWidth = 5
    .Columns("AC:AE").ColumnWidth = 5
    .Range("A5:AG" & Rows.Count) = ""
    .Range("F5:AG" & Rows.Count).Interior.Pattern = xlNone
    .Range("M5:R" & Rows.Count).NumberFormatLocal = "@" '値を元の内容で表示する為に書式を文字列にする
    .Range("AF5:AF" & Rows.Count).NumberFormatLocal = "@"
   
    
    '以下のメッセージが出た場合
    '「'Microsoft.ACE.OLEDB.12.0' プロバイダはローカルのコンピュータに登録されていません。」
    '(.mdb)と(.accdb)のどちらも読めるようにするには(Office 2007)以降のドライバーが必要です
    '以下からダウンロード可能
    '「Microsoft Access データベース エンジン 2010 再頒布可能コンポーネント」
    'http://www.microsoft.com/ja-jp/download/details.aspx?id=13255
    
    ado_cat.ActiveConnection = "Provider='Microsoft.ACE.OLEDB.12.0';" & _
        "Data Source='" & TargetDB & "';"
      
    Set ado_con = ado_cat.ActiveConnection
    Set dao_dbo = DAO.OpenDatabase(TargetDB, False, True)
    
      
    .Range("B5") = "テーブル一覧"
    .Range("B5:D5").Interior.Color = rgbKhaki
    
    Line = 6
      
    For Each ado_tbl In ado_cat.Tables
        .Range("B" & Line) = ado_tbl.Name
        Line = Line + 1
    Next
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Line = 5
      
    For Each ado_tbl In ado_cat.Tables
        
        If "すべて (ｼｽﾃﾑ含め)" = TargetTable Then
            If ado_tbl.Name = "MSysACEs" Then GoTo SkipPermission
            If ado_tbl.Name = "MSysComplexColumns" Then GoTo SkipPermission
            If ado_tbl.Name = "MSysObjects" Then GoTo SkipPermission
            If ado_tbl.Name = "MSysQueries" Then GoTo SkipPermission
            If ado_tbl.Name = "MSysRelationships" Then GoTo SkipPermission
        
        ElseIf "すべて (ｼｽﾃﾑ除く)" = TargetTable Then
            If "MSys" = Left(ado_tbl.Name, 4) Then GoTo SkipPermission
            
        ElseIf ado_tbl.Name <> TargetTable Then
            GoTo SkipPermission
        
        End If
        
        .Range("F" & Line) = ado_tbl.Name
        .Range("G" & Line) = "Name"
        .Range("H" & Line) = "Key/index"
        .Range("I" & Line) = "Type"
        .Range("J" & Line) = "全桁"
        .Range("K" & Line) = "小数桁"
        .Range("L" & Line) = "属性"
        .Range("M" & Line) = "書式"         'Format
        .Range("N" & Line) = "定型入力"     'InputMask
        .Range("O" & Line) = "表題"         'Caption
        .Range("P" & Line) = "規定値"       'DefaultValue
        .Range("Q" & Line) = "入力規則"     'ValidationRule
        .Range("R" & Line) = "ｴﾗｰ文言"      'ValidationText
        .Range("S" & Line) = "値要求"       'Required
        .Range("T" & Line) = "空文字"       'AllowZeroLength
        .Range("U" & Line) = "ｲﾝﾃﾞｯｸｽ"      'Indexed
        .Range("V" & Line) = "Unicd圧縮"    'UnicodeCompression
        .Range("W" & Line) = "IME入力"      'IMEMode
        .Range("X" & Line) = "IMEﾓｰﾄﾞ"      'IMESentenceMode
        .Range("Y" & Line) = "ﾌﾘｶﾞﾅ"        'FuriganaControl
        .Range("Z" & Line) = "住所入力"     'PostalAddress
        .Range("AA" & Line) = "文字配置"    'TextAlign
        .Range("AB" & Line) = "文字書式"    'TextFormat
        .Range("AC" & Line) = "追加のみ"    'AppendOnly
        .Range("AD" & Line) = "ｶﾚﾝﾀﾞｰ"      'ShowDatePicker
        .Range("AE" & Line) = "小数表桁"    'DecimalPlaces
        .Range("AF" & Line) = "説明"        'Description
        .Range("AG" & Line) = "他ﾌﾟﾛﾊﾟﾃｨ"
        .Range("F" & Line & ":AG" & Line).Interior.Color = rgbKhaki
        
        'Fieldを参照するにあたり二通りの選択肢がある
        
        '1:DAOのRecordsetからFieldsを取得
        Set dao_rst = dao_dbo.OpenRecordset("SELECT * FROM " & ado_tbl.Name)
        Set dao_fls = dao_rst.Fields
        
        '2:ADOXのRecordsetからFieldsを取得
        Set ado_rst = ado_con.OpenSchema(adSchemaColumns, Array(Empty, Empty, ado_tbl.Name))
        Set ado_fls = ado_rst.Fields
        
        '3:Fieldのループ中にADOXのColumnを参照する
        
        If "TABLE" = .Type Then
            'Indexの取得も二通りある
        
            '1:ADOXのTable定義からIndexを取得する
            Set ado_idx = ado_tbl.Indexes
        
            '2:DAO接続のTable定義からIndexを取得する
            Set dao_idx = Nothing
        
            For i = 0 To (dao_dbo.TableDefs.Count - 1)
                If dao_dbo.TableDefs(i).Name = ado_tbl.Name Then
                    Set dao_idx = dao_dbo.TableDefs(i).Indexes
                    Exit For
                End If
            Next
        End If
        
        'Field順はDAOの順で作成する
        For i = 0 To (dao_fls.Count - 1)

            Line = Line + 1
            
            'ADOXのColumnを参照する（DAOに対応するインデックスを記憶）
            Set ado_clm = Nothing
            
            For j = 0 To (ado_tbl.Columns.Count - 1)
                If ado_tbl.Columns(j).Name = dao_fls(i).Name Then
                    Set ado_clm = ado_tbl.Columns(j)
                    TblIdx = j
                    Exit For
                End If
            Next
            
            '二通りのどちらかを使う
            'With ado_fls(TblIdx)
            With dao_fls(i)
            
            '項目名
            Sh.Range("G" & Line) = .Name
            Sh.Range("G" & Line).Errors.Item(xlNumberAsText).Ignore = True

            'インデックスも二通りのどちらかを使う
            If "TABLE" = ado_tbl.Type Then
            For j = 0 To (dao_idx.Count - 1)
                If 0 < Len(dao_idx(j).Name) Then
                    For k = 0 To (dao_idx(j).Fields.Count - 1)
                        If dao_idx(j).Fields(k).Name = dao_fls(i).Name Then
                            Sh.Range("H" & Line) = dao_idx(j).Name
                            Exit For
                        End If
                    Next
                End If
                If dao_idx(j).Name = dao_fls(i).Name Then
                    If dao_idx(j).Unique = False Then
                        Sh.Range("H" & Line) = "index重複"
                    Else
                        Sh.Range("H" & Line) = "index"
                    End If
                End If
            Next
            End If
            
            'タイプ
            Sh.Range("I" & Line) = GetFieldTypeName(.Type)
            
            '桁数
            Select Case .Type
            Case dbByte, dbInteger, dbLong
                Sh.Range("J" & Line) = ado_clm.Precision
            Case dbCurrency
                Sh.Range("J" & Line) = ado_clm.Precision
                Sh.Range("K" & Line) = 4
            Case dbSingle
                Sh.Range("J" & Line) = ado_clm.Precision
                Sh.Range("K" & Line) = 7
            Case dbDouble
                Sh.Range("J" & Line) = ado_clm.Precision
                Sh.Range("K" & Line) = 15
            Case dbNumeric, dbDecimal
                Sh.Range("J" & Line) = ado_clm.Precision
                Sh.Range("K" & Line) = ado_clm.NumericScale
            Case dbBoolean, dbBinary, dbText
                Sh.Range("J" & Line) = .Size
            End Select
            
            '属性
            If CBool(.Attributes And dbAutoIncrField) Then
                If "" <> Sh.Range("L" & Line) Then Sh.Range("L" & Line) = Sh.Range("L" & Line) & ", "
                Sh.Range("L" & Line) = Sh.Range("L" & Line) & "ｲﾝｸﾘﾒﾝﾄ"
            End If
            If CBool(.Attributes And dbDescending) Then
                If "" <> Sh.Range("L" & Line) Then Sh.Range("L" & Line) = Sh.Range("L" & Line) & ", "
                Sh.Range("L" & Line) = Sh.Range("L" & Line) & "降順"
            End If
            If CBool(.Attributes And dbFixedField) Then
                If "" <> Sh.Range("L" & Line) Then Sh.Range("L" & Line) = Sh.Range("L" & Line) & ", "
                Sh.Range("L" & Line) = Sh.Range("L" & Line) & "固定長"
            End If
            If CBool(.Attributes And dbVariableField) Then
                If "" <> Sh.Range("L" & Line) Then Sh.Range("L" & Line) = Sh.Range("L" & Line) & ", "
                Sh.Range("L" & Line) = Sh.Range("L" & Line) & "可変長"
            End If
            If CBool(.Attributes And dbHyperlinkField) Then
                If "" <> Sh.Range("L" & Line) Then Sh.Range("L" & Line) = Sh.Range("L" & Line) & ", "
                Sh.Range("L" & Line) = Sh.Range("L" & Line) & "ﾊｲﾊﾟｰﾘﾝｸ"
            End If
            If CBool(.Attributes And dbSystemField) Then
                If "" <> Sh.Range("L" & Line) Then Sh.Range("L" & Line) = Sh.Range("L" & Line) & ", "
                Sh.Range("L" & Line) = Sh.Range("L" & Line) & "ｼｽﾃﾑ"
            End If
            '元々このレコードセットはReadOnly
            'If False = CBool(.Attributes And dbUpdatableField) Then
            '    If "" <> sh.Range("L" & Line) Then sh.Range("L" & Line) = sh.Range("L" & Line) & ", "
            '    sh.Range("L" & Line) = sh.Range("L" & Line) & "更新不可"
            'End If
            
            'それ以降
            For j = 0 To (.Properties.Count - 1)
            
                Select Case .Properties(j).Name
                Case "Format":
                    Sh.Range("M" & Line) = .Properties(j).Value
                
                Case "InputMask":
                    Sh.Range("N" & Line) = .Properties(j).Value
                
                Case "Caption":
                    Sh.Range("O" & Line) = .Properties(j).Value
                
                Case "DefaultValue":
                    Sh.Range("P" & Line) = .Properties(j).Value
                    Sh.Range("P" & Line).Errors.Item(xlNumberAsText).Ignore = True
                
                Case "ValidationRule":
                    Sh.Range("Q" & Line) = .Properties(j).Value
                
                Case "ValidationText":
                    Sh.Range("R" & Line) = .Properties(j).Value
                
                Case "Required":
                    Sh.Range("S" & Line) = GetTrueMark(.Properties(j).Value)
                
                Case "AllowZeroLength":
                    Sh.Range("T" & Line) = GetTrueMark(.Properties(j).Value)
                
                Case "Indexed":
                    Sh.Range("U" & Line) = .Properties(j).Value
                
                Case "UnicodeCompression":
                    Sh.Range("V" & Line) = .Properties(j).Value
                
                Case "IMEMode":
                    Sh.Range("W" & Line) = .Properties(j).Value
                
                Case "IMESentenceMode":
                    Sh.Range("X" & Line) = .Properties(j).Value
                
                Case "FuriganaControl":
                    Sh.Range("Y" & Line) = .Properties(j).Value
                
                Case "PostalAddress":
                    Sh.Range("Z" & Line) = .Properties(j).Value
                
                Case "TextAlign":
                    Select Case .Properties(j).Value
                    Case 0: Sh.Range("AA" & Line) = "標準"
                    Case 1: Sh.Range("AA" & Line) = "左"
                    Case 2: Sh.Range("AA" & Line) = "中央"
                    Case 3: Sh.Range("AA" & Line) = "右"
                    Case 4: Sh.Range("AA" & Line) = "均等"
                    End Select
                    Sh.Range("AA" & Line) = Sh.Range("AA" & Line) & "(" & .Properties(j).Value & ")"
                
                Case "TextFormat":
                    Select Case .Properties(j).Value
                    Case 0: Sh.Range("AB" & Line) = "テキスト"
                    Case 1: Sh.Range("AB" & Line) = "リッチテキスト"
                    End Select
                    Sh.Range("AB" & Line) = Sh.Range("AB" & Line) & "(" & .Properties(j).Value & ")"
                
                Case "AppendOnly":
                    Sh.Range("AC" & Line) = GetTrueMark(.Properties(j).Value)
                
                Case "ShowDatePicker":
                    If "" <> .Properties(j).Value Then
                        Sh.Range("AD" & Line) = "表示(" & .Properties(j).Value & ")"
                    End If
                
                Case "DecimalPlaces":
                    If 255 = .Properties(j).Value Then
                        Sh.Range("AE" & Line) = "自動"
                    Else
                        Sh.Range("AE" & Line) = .Properties(j).Value
                    End If
                
                Case "Description":
                    Sh.Range("AF" & Line) = .Properties(j).Value
                    
                Case "Value", "Type", "Name", "Attributes", "GUID":
                Case "OriginalValue":
                Case "VisibleValue":
                Case "ForeignName":
                Case "FieldSize":
                Case "CollatingOrder":
                    'skip
                
                'Case "ValidateOnSet":
                'Case "Size":
                'Case "DataUpdatable":
                'Case "OrdinalPosition":    'フィールド定義順
                'Case "DisplayControl":     '[ルックアップ]の表示コントロール種類
                'Case "CurrencyLCID":
                    
                Case Else
                    Sh.Range("AG" & Line) = _
                    Sh.Range("AG" & Line) & .Properties(j).Name & "=" & .Properties(j).Value & ", "
                End Select
            Next
            End With
        Next
        
        ado_rst.Close
        dao_rst.Close
        Set ado_rst = Nothing
        Set dao_rst = Nothing
        
        Line = Line + 2
        
SkipPermission:
    Next
    
    .Range("G5:K" & Line).HorizontalAlignment = xlRight
    .Columns("F:G").EntireColumn.AutoFit
    .Columns("F:K").ColumnWidth = 13
    .Columns("I:K").EntireColumn.AutoFit
    .Columns("S:X").EntireColumn.AutoFit
    .Columns("AA:AA").EntireColumn.AutoFit
    .Columns("AC:AE").EntireColumn.AutoFit
    End With
      
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    ado_con.Close
    dao_dbo.Close
    Set ado_clm = Nothing
    Set ado_rst = Nothing
    Set ado_tbl = Nothing
    Set ado_con = Nothing
    Set ado_cat.ActiveConnection = Nothing
    Set ado_cat = Nothing
    Set dao_dbo = Nothing
    Exit Sub
      
dbError:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    Set ado_clm = Nothing
    Set ado_rst = Nothing
    Set ado_tbl = Nothing
    Set ado_con = Nothing
    Set ado_cat = Nothing
    Set dao_dbo = Nothing
  
    MsgBox Err.Source & "-->" & Err.Description, , "Error"
End Sub

'項目タイプ名の取得
Function GetFieldTypeName(param1 As Integer) As String
On Error Resume Next

    GetFieldTypeName = ""
    
    Select Case param1
    Case dbBoolean:     GetFieldTypeName = "Yes/No型"                '1
    Case dbByte:        GetFieldTypeName = "バイト型"                '2
    Case dbInteger:     GetFieldTypeName = "整数型"                  '3
    Case dbLong:        GetFieldTypeName = "長整数型/ｵｰﾄﾅﾝﾊﾞｰ型"     '4
    Case dbCurrency:    GetFieldTypeName = "通貨型"                  '5
    Case dbSingle:      GetFieldTypeName = "単精度浮動小数点型"      '6
    Case dbDouble:      GetFieldTypeName = "倍精度浮動小数点型"      '7
    Case dbDate:        GetFieldTypeName = "日付/時刻型"             '8
    Case dbBinary:      GetFieldTypeName = "バイナリ―型"            '9
    Case dbText:        GetFieldTypeName = "短いテキスト"            '10
    Case dbLongBinary:  GetFieldTypeName = "OLE オブジェクト型"      '11
    Case dbMemo:        GetFieldTypeName = "長いテキスト/ﾊｲﾊﾟｰﾘﾝｸ型" '12
    Case dbGUID:        GetFieldTypeName = "レプリケーション ID型"   '15
    Case dbBigInt:      GetFieldTypeName = "dbBigInt 型"             '16
    Case dbVarBinary:   GetFieldTypeName = "dbVarBinary 型"          '17
    Case dbChar:        GetFieldTypeName = "dbChar 型"               '18
    Case dbNumeric:     GetFieldTypeName = "dbNumeric 型"            '19
    Case dbDecimal:     GetFieldTypeName = "十進型"                  '20
    Case dbFloat:       GetFieldTypeName = "dbFloat 型"              '21
    Case dbTime:        GetFieldTypeName = "dbTime 型"               '22
    Case dbTimeStamp:   GetFieldTypeName = "dbTimeStamp 型"          '23
    Case dbAttachment:  GetFieldTypeName = "添付ファイル"            '101
    '102,103,104,105,106,107,108,109
    Case dbComplexByte, dbComplexInteger, dbComplexLong, dbComplexSingle, _
        dbComplexDouble, dbComplexGUID, dbComplexDecimal, dbComplexText:
                        GetFieldTypeName = "圧縮型"
    Case Else:          GetFieldTypeName = "不明"
    End Select
    GetFieldTypeName = GetFieldTypeName & "(" & param1 & ")"

End Function

'Trueを○に変換
Function GetTrueMark(param1 As Variant) As String
On Error Resume Next
    GetTrueMark = ""
    If True = param1 Then
        GetTrueMark = "○"
    ElseIf "TRUE" = UCase(param1) Then
        GetTrueMark = "○"
    End If
End Function