テーブル定義を作成する関数

昨日の続き。
引数でDBファイルを指定し、そのDBに関するテーブル定義を作成するようにしました。

Public Function DumpTableDef(sDBFileName As String) As Boolean
On Error GoTo Trap
  Dim db As DAO.Database
  Dim tdf As DAO.TableDef
  Dim fld As DAO.Field2
  Dim fs As FileSystemObject
  Dim ts As TextStream
  Dim idx As DAO.Index
  Dim fld2 As Field2
  Dim buf As String
  Dim rs As DAO.Recordset
  Dim i As Long
  Dim sPath As String
  Dim rl As DAO.Relation
  
  Set fs = New FileSystemObject
  
  If Dir(sDBFileName) = "" Then
    DumpTableDef = False
    Exit Function
  End If
  
  Set db = DBEngine.OpenDatabase(sDBFileName, , True)
  sPath = Left(db.Name, InStrRev(db.Name, ".") - 1)
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  If Dir(sPath & "\TableDefs", vbDirectory) = "" Then MkDir sPath & "\TableDefs"
  sPath = sPath & "\TableDefs"
  
  If db.Relations.Count > 0 Then
    Set ts = fs.CreateTextFile(sPath & "\relations.txt", True)
    For Each rl In db.Relations
      buf = ""
      ts.WriteLine "リレーション名" & vbTab & "テーブル名" & vbTab & "外部テーブル名" & vbTab & "特記事項" & vbTab & "結合フィールド"
      ts.Write rl.Name & vbTab & rl.Table & vbTab & rl.ForeignTable & vbTab
      If rl.Attributes And dbRelationDeleteCascade Then buf = buf & "連鎖削除"
      If rl.Attributes And dbRelationUpdateCascade Then
        If buf <> "" Then buf = buf & "/"
        buf = buf & "連鎖更新"
      End If
      If rl.Attributes And dbRelationUnique Then
        If buf <> "" Then buf = buf & "/"
        buf = buf & "1対1"
      End If
      If rl.Attributes And dbRelationDontEnforce Then
        If buf <> "" Then buf = buf & "/"
        buf = buf & "参照整合性なし"
      End If
      ts.Write buf & vbTab
      
      buf = ""
      For Each fld2 In rl.Fields
        If buf <> "" Then buf = buf & ","
        buf = buf & fld2.Name
      Next fld2
      ts.WriteLine buf
    Next rl
  End If
  
  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(sPath & "\" & tdf.SourceTableName & ".txt", True)
      ts.Write tdf.SourceTableName & vbTab & "特記事項:"
      buf = buf & "リンクテーブルODBC(" & tdf.Connect & ")"
    Else
      Set ts = fs.CreateTextFile(sPath & "\" & 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 & "必須" & 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 fld.Required Then ts.Write "必須"
    'データのサンプル
      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
    End If
  Next tdf
  DumpTableDef = True
  Exit Function
Trap:
  Debug.Print Err.Number & ":" & Err.Description
  DumpTableDef = False
End Function