Attribute VB_Name = "SQLtool"
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

'Class:   SQLtool
'Goal:    create a SQL-script to setup current project
'Usage:   a call to createDatabase
'USES     classes OrderedReeks, StringObj

Dim white As String
Dim SQLs As New OrderedReeks 'this is a module level variable out of laziness. If you do better, go ahead.

Sub createDatabase(ByVal cFile As String, ByVal bUseWhiteSpace As Boolean, ByVal cExclude As String)
'ROUTINE : createDatabase
'PURPOSE : store current database tables as SQL-script
'INPUT   : string cFile: filename to create script into
'           bool bUseWhiteSpace: make script file readable with tabs and end-of-line marks
'           string cExclude: do not include tables that begin with this string
'OUTPUT  : (file)
'USES    : Add, createStatement, write2file
'EFFECT  : .

Dim td As TableDef, nLen As Integer
   DoCmd.Hourglass True
   nLen = Len(cExclude)
   white = ""
   If bUseWhiteSpace Then white = vbNewLine & "      "
   For Each td In CurrentDb.TableDefs
      If Left(td.Name, nLen) <> cExclude Then
         SQLs.Add td.Name, createStatement(td)
      End If
   Next
   SQLs.write2file cFile
   DoCmd.Hourglass False
End Sub

Function createStatement(ByVal td As TableDef) As String
'ROUTINE : createStatement
'PURPOSE : change a TableDef into a SQL DDL string (CREATE TABLE)
'INPUT   : TableDef td: object to read
'OUTPUT  : string: script command
'USES    : getFields, getPrimary, getForeign; Init, Add, Value
'EFFECT  : .

Dim cRes As New StringObj
   cRes.Init getFields(td)
   cRes.Add getPrimary(td)
   cRes.Add getForeign(td)
   createStatement = "CREATE TABLE " & td.Name & "(" & cRes.Value & white & ");"
End Function

Private Function getPrimary(ByVal td As TableDef) As String
'ROUTINE : getPrimary
'PURPOSE : change the primary key of a table into a script command (PRIMARY KEY)
'INPUT   : TableDef td: object to read
'OUTPUT  : string: script command
'USES    : Add, Value
'EFFECT  : .

Dim ID As Index, fd As Field, cRes As New StringObj
   getPrimary = ""
   cRes.Init
   For Each ID In td.Indexes
      If ID.Primary Then
         For Each fd In ID.Fields
            cRes.Add fd.Name
         Next
         getPrimary = white & "PRIMARY KEY (" & cRes.Value & ")"
      End If
   Next
End Function

Private Function getFields(ByVal td As TableDef) As String
'ROUTINE : getFields
'PURPOSE : enumerate fields in table as SQL columns
'INPUT   : TableDef td: object to read
'OUTPUT  : string: script part
'USES    : SQLfieldType, SQLfieldOptions; Add, Value
'EFFECT  : .

Dim fd As Field, cRes As New StringObj
   cRes.Init
   For Each fd In td.Fields
      cRes.Add white & fd.Name & " " & SQLfieldType(fd) & SQLfieldOptions(fd, td)
   Next
   getFields = cRes.Value
End Function

Private Function getForeign(ByVal td As TableDef) As String
'ROUTINE : getForeign
'PURPOSE : translate relationships into script (note: a table can have more than 1 relationship, can't he?)
'INPUT   : TableDef td: object to read
'OUTPUT  : string: script part
'USES    : getForeignKey; Add, Value
'EFFECT  : .

Dim rl As relation, cRes As New StringObj
   cRes.Init
   For Each rl In CurrentDb.Relations
      If rl.ForeignTable = td.Name Then
         cRes.Add white & getForeignKey(rl)
      End If
   Next
   getForeign = cRes.Value
End Function

Private Function getForeignKey(ByVal rl As relation) As String
'ROUTINE : getForeignKey
'PURPOSE : change a single relationship into a script command
'INPUT   : Relation rl: object to read
'OUTPUT  : string: script command
'USES    : Add, Value; AddPair
'EFFECT  : .

Dim cFields As New StringObj, cRefFields As New StringObj, fd As Field, cFkName As String
Static Count As Integer
   Count = Count + 1
   cFkName = "FK" & format(Count, "00") & "_" & rl.ForeignTable & "_" & rl.table
   cFields.Init
   cRefFields.Init
   For Each fd In rl.Fields
      cRefFields.Add fd.Name
      cFields.Add fd.ForeignName
   Next
   getForeignKey = "FOREIGN KEY " & cFkName & " (" & cFields.Value & ") REFERENCES " & rl.table & "(" & cRefFields.Value & ")"
   SQLs.AddPair rl.table, rl.ForeignTable
End Function

Private Function SQLfieldType(ByVal fd As Field) As String
'ROUTINE : SQLfieldType
'PURPOSE : translate Access field types into SQL column types
'INPUT   : Field fd: object to read
'OUTPUT  : string: SQL column type
'USES    : .
'EFFECT  : .

   Select Case fd.Type
   Case dbByte
      SQLfieldType = "SMALLINT"
   Case dbInteger
      SQLfieldType = "INT"
   Case dbLong
      SQLfieldType = "BIGINT"
   Case dbText
      SQLfieldType = "VARCHAR(" & fd.size & ")"
   Case dbChar
      SQLfieldType = "CHAR(" & fd.size & ")"
   Case dbDouble, dbSingle
      SQLfieldType = "NUMERIC"
   Case dbNumeric
      SQLfieldType = "DECIMAL(" & fd.size & ")"
   Case dbBoolean
      SQLfieldType = "INT"
   Case dbMemo
      SQLfieldType = "CHAR(1024)"
   Case dbDate
      SQLfieldType = "DATE"
   Case Else
      SQLfieldType = " #ERROR#"
      'assertion failed? You check this
   End Select
End Function

Private Function SQLfieldOptions(ByVal fd As Field, ByVal td As TableDef) As String
'ROUTINE : SQLfieldOptions
'PURPOSE : get extra options (required, default value) into script
'INPUT   : Field fd: object to read
'           TableDef td: to check whether this field is (part of) the primary key
'OUTPUT  : string: script part
'USES    : inPrimary
'EFFECT  : .

Dim cRes As String, cDef As String
   cRes = ""
   If fd.Required Or inPrimary(fd, td) Then cRes = cRes & " NOT NULL"
   If fd.DefaultValue <> "" Then
      If fd.Type = dbBoolean Then
         cDef = IIf(fd.DefaultValue = "yes", -1, 0)
      Else
         cDef = fd.DefaultValue
      End If
      cRes = cRes & " DEFAULT " & cDef
   End If
   SQLfieldOptions = cRes
End Function

Private Function inPrimary(ByVal fd As Field, ByVal td As TableDef) As Boolean
'ROUTINE : inPrimary
'PURPOSE : check whether a field is (part of) the primary key
'INPUT   : Field fd: object to read
'           TableDef td: to check whether this field is (part of) the primary key
'OUTPUT  : bool: yes, the field is in the primary key
'USES    : .
'EFFECT  : .

Dim ID As Index, F2 As Field
   inPrimary = False
   For Each ID In td.Indexes
      If ID.Primary Then
         For Each F2 In ID.Fields
            If F2.Name = fd.Name Then
               inPrimary = True
               Exit Function
            End If
         Next
      End If
   Next
End Function