Option Compare Database
Option Explicit
Public Sub CallBuildSQL()
Dim sTableName As String
Dim sPathTextFile As String
sTableName = "[B][COLOR=red]TypeTableNameHere[/COLOR][/B]"
sPathTextFile = "[B][COLOR=red]Path where to save textfile[/COLOR][/B]\" [COLOR=seagreen]'include the last "\", eg c:\documents\[/COLOR]
BuildCreateSQL sTableName, sPathTextFile
End Sub
Public Sub BuildCreateSQL(ByVal sTableName As String, _
ByVal sPathTextFile As String)
Dim db As Database
Dim tdf As TableDef
Dim fld As DAO.Field
Dim ndx As DAO.Index
Dim sSQL As String
Dim sFlds() As String
Dim iFld As Integer
Dim sInd As String
Dim fs, f
Set db = CurrentDb
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(sPathTextFile & sTableName & ".txt")
For Each tdf In db.TableDefs
' If Left(tdf.Name, 4) <> "Msys" Then 'switch to this line for all tables
If tdf.Name = sTableName Then
sSQL = "sSQL=""CREATE TABLE [" & tdf.Name & "] ("
iFld = -1
For Each fld In tdf.Fields
iFld = iFld + 1
ReDim Preserve sFlds(iFld)
sFlds(iFld) = "[" & fld.Name & "] "
Select Case fld.Type
Case dbText
sFlds(iFld) = sFlds(iFld) & "Text (" & fld.Size & ")"
Case dbLong
If (fld.Attributes And dbAutoIncrField) = 0& Then
sFlds(iFld) = sFlds(iFld) & "Long"
Else
sFlds(iFld) = sFlds(iFld) & "Counter"
End If
Case dbBoolean
sFlds(iFld) = sFlds(iFld) & "YesNo"
Case dbByte
sFlds(iFld) = sFlds(iFld) & "Byte"
Case dbInteger
sFlds(iFld) = sFlds(iFld) & "Integer"
Case dbCurrency
sFlds(iFld) = sFlds(iFld) & "Currency"
Case dbSingle
sFlds(iFld) = sFlds(iFld) & "Single"
Case dbDouble
sFlds(iFld) = sFlds(iFld) & "Double"
Case dbDate
sFlds(iFld) = sFlds(iFld) & "DateTime"
Case dbBinary
sFlds(iFld) = sFlds(iFld) & "Binary"
Case dbLongBinary
sFlds(iFld) = sFlds(iFld) & "OLE Object"
Case dbMemo
If (fld.Attributes And dbHyperlinkField) = 0& Then
sFlds(iFld) = sFlds(iFld) & "Memo"
Else
sFlds(iFld) = sFlds(iFld) & "Hyperlink"
End If
Case dbGUID
sFlds(iFld) = sFlds(iFld) & "GUID"
End Select
Next
sSQL = sSQL & Join(sFlds, ", ") & " )""" & vbCrLf & "Currentdb.Execute sSQL"
f.WriteLine vbCrLf & sSQL
'Indexes
For Each ndx In tdf.Indexes
If ndx.Unique Then
sSQL = "sSQL=""CREATE UNIQUE INDEX "
Else
sSQL = "sSQL=""CREATE INDEX "
End If
sSQL = sSQL & "[" & ndx.Name & "] ON [" & tdf.Name & "] ("
iFld = -1
For Each fld In ndx.Fields
iFld = iFld + 1
ReDim Preserve sFlds(iFld)
sFlds(iFld) = "[" & fld.Name & "]"
Next fld
sSQL = sSQL & Join(sFlds, ", ") & ") "
sInd = ""
If ndx.Primary Then
sInd = " PRIMARY"
End If
If ndx.Required Then
sInd = sInd & " DISALLOW NULL"
End If
If ndx.IgnoreNulls Then
sInd = sInd & " IGNORE NULL"
End If
If Trim(sInd) <> vbNullString Then
sSQL = sSQL & " WITH" & sInd & " "
End If
f.WriteLine vbCrLf & sSQL & """" & vbCrLf & "Currentdb.Execute sSQL"
Next ndx
End If
Next
f.Close
End Sub