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