*Access テーブル定義自動作成

取り急ぎ自分用

Sub DumpTableDef()
'テーブル定義自動作成！！！
  Dim db As DAO.Database
  Dim tdf As DAO.TableDef
  Dim fld As DAO.Field
  Dim fs As FileSystemObject
  Dim ts As TextStream
  Dim idx As DAO.Index
  Dim fld2 As Field
  Dim buf As String
  Dim rs As DAO.Recordset
  Dim i As Long
  Set fs = New FileSystemObject
  
  Set db = CurrentDb
  For Each tdf In db.TableDefs
  'テーブルの種類
    If (tdf.Attributes And dbSystemObject) = 0 Then
    buf = ""
    Set rs = db.OpenRecordset(tdf.Name)
    If rs.BOF And rs.EOF Then
      Set rs = Nothing
    Else
      rs.MoveFirst
    End If
    If tdf.Attributes And dbAttachedODBC Then
      Set ts = fs.CreateTextFile(CurrentProject.Path & "\tabledefs\" & tdf.SourceTableName & ".txt", True)
      ts.Write tdf.SourceTableName & vbTab & "特記事項:"
      buf = buf & "リンクテーブルODBC(" & tdf.Connect & ")"
    Else
      Set ts = fs.CreateTextFile(CurrentProject.Path & "\tabledefs\" & tdf.Name & ".txt", True)
      ts.Write tdf.Name & vbTab & "特記事項:"
    End If
    If tdf.Attributes And dbAttachedTable Then
      If buf <> "" Then buf = buf & ","
      buf = buf & "リンクテーブル(" & tdf.Connect & ")"
    End If
    If tdf.Attributes And dbAttachExclusive Then
      If buf <> "" Then buf = buf & ","
      buf = buf & "排他Open"
    End If
    
    If tdf.Attributes And dbAttachSavePWD Then
      If buf <> "" Then buf = buf & ","
      buf = buf & "パスワード保存済"
    End If
    
    If tdf.Attributes And dbHiddenObject Then
      If buf <> "" Then buf = buf & ","
      buf = buf & "隠しオブジェクト"
    End If
    ts.WriteLine buf
    'フィールド定義のヘッダ
    ts.WriteLine "フィールド名" & vbTab & "型" & vbTab & "size" & vbTab & "主キー" & vbTab & "サンプル"
    i = 0
    For Each fld In tdf.Fields
      ts.Write fld.Name & vbTab
      Select Case fld.Type
        Case dbBigInt
        ts.Write "多倍長整数型 (Big Integer)"
        Case dbBinary
        ts.Write "バイナリ型 (Binary)"
        Case dbBoolean
        ts.Write "ブール型 (Boolean)"
        Case dbByte
        ts.Write "バイト型 (Byte)"
        Case dbChar
        ts.Write "文字型 (Char)"
        Case dbCurrency
        ts.Write "通貨型 (Currency)"
        Case dbDate
        ts.Write "日付/時刻型 (Date/Time)"
        Case dbDecimal
        ts.Write "10 進型 (Decimal)"
        Case dbDouble
        ts.Write "倍精度浮動小数点型 (Double)"
        Case dbFloat
        ts.Write "浮動小数点型 (Float)"
        Case dbGUID
        ts.Write "GUID 型 (GUID)"
        Case dbInteger
        ts.Write "整数型 (Integer)"
        Case dbLong
        If fld.Attributes And dbAutoIncrField Then
          ts.Write "オートナンバー型(Long)"
        Else
          ts.Write "Long 型 (Long)"
        End If
        Case dbLongBinary
        ts.Write "ロング バイナリ型 (Long Binary) - OLE オブジェクト型 (OLE Object)"
        Case dbMemo
        ts.Write "メモ型 (Memo)"
        Case dbNumeric
        ts.Write "数値型 (Numeric)"
        Case dbSingle
        ts.Write "単精度浮動小数点型 (Single)"
        Case dbText
        ts.Write "テキスト型 (Text)"
        Case dbTime
        ts.Write "時刻型 (Time)"
        Case dbTimeStamp
        ts.Write "タイムスタンプ型 (TimeStamp)"
        Case dbVarBinary
        ts.Write "可変長バイナリ型 (VarBinary)"
        Case Else
        ts.Write "不明(" & fld.Type & ")"
      End Select
      ts.Write vbTab
      ts.Write fld.Size & vbTab
      'PK情報
      For Each idx In tdf.Indexes
        If idx.Primary Then
          For Each fld2 In idx.Fields
            If fld2.Name = fld.Name Then ts.Write "PK"
          Next fld2
        End If
      Next idx
    'データのサンプル
      ts.Write vbTab
      If Not (rs Is Nothing) Then
        ts.Write Nz(rs.Fields(i), "")
      End If
      ts.WriteLine
      i = i + 1
    Next fld
    ts.Close
    DoEvents
    Debug.Print Now(), tdf.Name, "Done"
    End If
  Next tdf

End Sub