Option Compare Database

Option Explicit

Global Const MyOutputFile = "TEST.SQL"

Global Const DropExistingTable = True

Sub MakeTables()

Dim db As DAO.Database, tdf As TableDef, s As String

Set db = CurrentDb

s = "/*" & vbCrLf

s = s & vbTab & "MSSQL 2005 script to create tables from MS-Access" & vbCrLf

s = s & vbTab & "generated " & Format(Now(), "Long Date") & " at " & Format(Now(), "hh:nn AMPM") & vbCrLf

s = s & "*/" & vbCrLf

For Each tdf In db.TableDefs

If Left(tdf.Name, 4) <> "MSys" Then

s = s & MakeTable(tdf.Name)

End If

Next tdf

Open Environ("USERPROFILE") & "\DESKTOP\" & MyOutputFile For Output As #1

Print #1, s

Close #1

End Sub

Function MakeTable(T As String) As String

'

Dim db As DAO.Database, tdf As DAO.TableDef

Dim fld As DAO.Field, idx As DAO.Index

Dim s As String, HasPK As Boolean, NamePK As String

Dim bNulls As Boolean, sDefault As String

'

Set db = CurrentDb

Set tdf = db.TableDefs(T)

' drop table if it exists

If DropExistingTable Then

s = s & "IF EXISTS (SELECT * FROM sys.objects WHERE object_id = OBJECT_ID(N'[dbo].[" & tdf.Name & "]') "

s = s & "AND type in (N'U'))" & vbCrLf

s = s & "DROP TABLE [dbo].[" & tdf.Name & "]" & vbCrLf

s = s & "GO" & vbCrLf & vbCrLf

End If

' create table

s = s & "CREATE TABLE dbo.[" & T & "]" & vbCrLf

s = s & vbTab & "(" & vbCrLf

For Each fld In tdf.Fields

s = s & vbTab & "[" & fld.Name & "] "

If (fld.Attributes And dbAutoIncrField) = dbAutoIncrField Then

s = s & "int IDENTITY(1,1) "

Else

s = s & wm_DataType(fld.Type)

End If

' memo fields => nvarchar(4000)

Select Case fld.Type

Case 10, 12

If fld.Size = 0 Then

s = s & "(4000)"

Else

s = s & "(" & fld.Size & ")"

End If

End Select

' get PK if exists

For Each idx In tdf.Indexes

If idx.Primary = True Then

HasPK = True

NamePK = Replace(idx.Fields, "+", "")

End If

Next idx

' check for nullability

bNulls = True

If fld.Required = True Then

bNulls = False ' required => not null

ElseIf (fld.Attributes And dbAutoIncrField) = dbAutoIncrField Then

bNulls = False ' autonumber => not null

End If

If Not bNulls Then

s = s & " NOT"

End If

s = s & " NULL"

' default values

Select Case fld.Type

Case 1 ' boolean

If Not IsNull(fld.DefaultValue) Then

s = s & " CONSTRAINT [DF_" & tdf.Name & "_" & fld.Name & "] DEFAULT ("

If fld.DefaultValue = "Yes" Then

s = s & "1"

Else

s = s & "0"

End If

s = s & ")"

End If

Case 2 To 7 ' all numeric fields

If Len(fld.DefaultValue) > 0 Then

s = s & " CONSTRAINT [DF_" & tdf.Name & "_" & fld.Name & "] DEFAULT (" & fld.DefaultValue & ")"

End If

Case 8 ' dates

If Not IsNull(fld.DefaultValue) Then

If InStr(1, fld.DefaultValue, "Now") > 0 Or InStr(1, fld.DefaultValue, "Date") > 0 Then

s = s & " CONSTRAINT [DF_" & tdf.Name & "_" & fld.Name & "] DEFAULT ( GETDATE() )"

End If

End If

Case 10, 12 ' text

sDefault = Nz(fld.DefaultValue, "")

If Len(sDefault) > 0 Then

Select Case sDefault

Case "=Environ(""USERNAME"")"

sDefault = "SUSER_SNAME()"

Case Else

sDefault = Replace(sDefault, """", "'")

End Select

s = s & " CONSTRAINT [DF_" & tdf.Name & "_" & fld.Name & "] DEFAULT (" & sDefault & ")"

End If

End Select

' PK definition goes after the last field

If fld.Name = tdf.Fields(tdf.Fields.Count - 1).Name Then

' primary key

If HasPK = True Then

s = s & vbCrLf & "PRIMARY KEY CLUSTERED" & vbCrLf

s = s & vbTab & "(" & vbCrLf

s = s & vbTab & "[" & NamePK & "] ASC " & vbCrLf

s = s & vbTab & ")" & vbCrLf

s = s & vbTab & "WITH (" & vbCrLf

s = s & vbTab & vbTab & "PAD_INDEX = OFF, IGNORE_DUP_KEY = OFF, FILLFACTOR = 90" & vbCrLf

s = s & vbTab & vbTab & ") ON [PRIMARY]" & vbCrLf

s = s & vbTab & ") ON [PRIMARY]" & vbCrLf & "GO" & vbCrLf & vbCrLf

Else

s = s & vbCrLf & ") ON [PRIMARY]" & vbCrLf & "GO" & vbCrLf & vbCrLf

End If

Else

' use comma, until reaching the last field

s = s & "," & vbCrLf

End If

Next fld

'

' indexes

For Each idx In tdf.Indexes

If Not idx.Primary Then

s = s & "CREATE "

If idx.Unique Then

s = s & "UNIQUE "

End If

s = s & "NONCLUSTERED INDEX IX_" & tdf.Name & "_" & Right(idx.Fields, Len(idx.Fields) - 1) & " ON dbo.[" & tdf.Name & "]" & vbCrLf

s = s & vbTab & "(" & vbCrLf

s = s & vbTab & Right(idx.Fields, Len(idx.Fields) - 1)

Select Case Left(idx.Fields, 1)

Case "+"

s = s & " ASC"

Case "-"

s = s & " DESC"

End Select

s = s & vbCrLf

s = s & vbTab & ")" & vbCrLf

s = s & vbTab & "WITH (" & vbCrLf

s = s & vbTab & vbTab & "STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON" & vbCrLf

s = s & vbTab & vbTab & ") ON [PRIMARY]" & vbCrLf

s = s & "GO" & vbCrLf

End If

Next idx

'

MakeTable = s

'

Set fld = Nothing

Set tdf = Nothing

Set db = Nothing

End Function

Function wm_DataType(TypeNumber)

Select Case TypeNumber

Case 1

wm_DataType = "bit"

Case 2

wm_DataType = "tinyint"

Case 3

wm_DataType = "smallint"

Case 4

wm_DataType = "int"

Case 5

wm_DataType = "money"

Case 6

wm_DataType = "decimal"

Case 7

wm_DataType = "float"

Case 8

wm_DataType = "datetime"

Case 10

wm_DataType = "nvarchar"

Case 11

wm_DataType = "image"

Case 12

wm_DataType = "nvarchar"

End Select

End Function