Code to upsize individual tables to SQL Server (1 Viewer)

Public Sub UpsizeTable( _
    ByVal sServer As String, _
    ByVal sDataBase As String, _
    ByVal sTableName As String, _
    Optional ByVal vUID, _
    Optional ByVal vPWD, _
    Optional ByVal vSourceDB, _
    Optional ByVal vSourcePWD)

    Dim bIdentity As Boolean
    
    Dim cat As Object
    Dim cn As Object
    Dim cnDB As Object
    Dim rd As Object
    
    Dim db As Object
    Dim rs As Object
    Dim td As Object
    Dim fd As Object
    Dim id As Object
    
    Dim rCount As Long
    Dim rNumber As Long
    Dim sID As String
    Dim sSQL As String
    
    Set cat = CreateObject("ADOX.Catalog")
    If IsMissing(vSourceDB) = True Then
        Set db = CurrentDb
        Set cnDB = CurrentProject.Connection
    Else
        If IsMissing(vSourcePWD) = True Then
            Set db = DBEngine(0).OpenDatabase(CStr(vSourceDB), False, False)
        Else
            Set db = DBEngine(0).OpenDatabase(CStr(vSourceDB), False, False, _
            ";PWD=" & CStr(vSourcePWD))
        End If
        Set cnDB = CreateObject("ADODB.Connection")
        With cnDB
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            If IsMissing(vSourcePWD) = False Then
                .Properties("Jet OLEDB:Database Password") = CStr(vSourcePWD)
            End If
            .Open ConnectionString:="Data Source=" & CStr(vSourceDB)
        End With
    End If
    cat.ActiveConnection = cnDB
    
    Set td = db.TableDefs(sTableName)
    
    For Each fd In td.Fields
        sSQL = sSQL & ", " & IIf(InStr(1, fd.Name, " ") > 0, _
            "[" & fd.Name & "]", fd.Name) & " "
        Select Case fd.Type
            Case dbText
                sSQL = sSQL & "nvarchar(" & CStr(fd.Size) & ")"
            Case dbMemo
                sSQL = sSQL & "ntext"
            Case dbByte, dbInteger
                sSQL = sSQL & "smallint"
            Case dbLong
                sSQL = sSQL & "int"
            Case dbSingle
                sSQL = sSQL & "real"
            Case dbDouble
                sSQL = sSQL & "float(53)"
            Case dbDecimal
                With cat.Tables(sTableName).Columns(fd.Name)
                    sSQL = sSQL & "decimal(" _
                        & .Precision & ", " _
                        & .NumericScale & ")"
                End With
            Case dbDate
                sSQL = sSQL & "datetime"
            Case dbCurrency
                sSQL = sSQL & "money"
            Case dbBoolean
                sSQL = sSQL & "bit"
            Case dbLongBinary
                sSQL = sSQL & "image"
            Case dbGUID
                sSQL = sSQL & "uniqueidentifier"
        End Select
        sSQL = sSQL & IIf((fd.Required = True) _
            Or ((fd.Attributes And 16) = 16), " NOT NULL", " NULL")
        If (fd.Attributes And 16) = 16 Then
            bIdentity = True
            sSQL = sSQL & " IDENTITY (1, 1)"
        End If
    
    Next fd
    
    sSQL = "CREATE TABLE dbo.[" & sTableName _
        & "] (" & Mid(sSQL, 2) _
        & ") ON [PRIMARY]"
    
    For Each id In td.Indexes
        sID = ""
        For Each fd In id.Fields
            sID = sID & ",[" & fd.Name & "]"
        Next fd
        If id.Primary = True Then
            sSQL = sSQL & ";ALTER TABLE dbo.[" & sTableName _
                & "] ADD CONSTRAINT aaaaa" & Replace(sTableName, " ", "_") _
                & "_PK PRIMARY KEY NONCLUSTERED (" & Mid(sID, 2) _
                & ") WITH( STATISTICS_NORECOMPUTE = OFF, " _
                & "IGNORE_DUP_KEY = OFF, " _
                & "ALLOW_ROW_LOCKS = ON, " _
                & "ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]"
        Else
            sSQL = sSQL & ";CREATE " & IIf(id.Unique = True, "UNIQUE", "") _
                & " NONCLUSTERED INDEX [" & id.Name _
                & "] ON dbo.[" & sTableName _
                & "] (" & Mid(sID, 2) _
                & ") WITH( STATISTICS_NORECOMPUTE = OFF, " _
                & "IGNORE_DUP_KEY = OFF, " _
                & "ALLOW_ROW_LOCKS = ON, " _
                & "ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]"
        End If
    Next id
    
    Set cn = New ADODB.Connection
    With cn
        .CursorLocation = adUseServer
        .Open "Provider=sqloledb" _
            & ";Data Source=" & sServer _
            & ";Initial Catalog=" & sDataBase _
            & IIf(IsMissing(vUID) = True, _
                ";Integrated Security=SSPI", _
                ";User Id=" & CStr(vUID) _
                & ";Password=" & CStr(vPWD)) _
            & ";"
    End With
    
    cn.Execute sSQL
    
    If cn.Errors.Count > 0 Then
    Else
        Set rs = db.OpenRecordset("SELECT COUNT(*) FROM [" _
            & sTableName & "]", dbOpenSnapshot)
        If IsNumeric(rs.Fields(0)) = True Then
            rCount = rs.Fields(0)
        End If
        rs.Close
        Set rs = Nothing
        If rCount > 0 Then
            Set rs = db.OpenRecordset(sTableName, dbOpenSnapshot)
            If bIdentity = True Then
                cn.Execute "SET IDENTITY_INSERT dbo.[" & sTableName & "] ON"
            End If
            Set rd = CreateObject("ADODB.Recordset")
            SysCmd acSysCmdInitMeter, "Migrating table:", rCount
            rd.Open sTableName, cn, _
                adOpenForwardOnly, _
                adLockOptimistic, _
                adCmdTableDirect
            Do While Not rs.EOF
                rNumber = rNumber + 1
                SysCmd acSysCmdUpdateMeter, rNumber
                rd.AddNew
                For Each fd In rs.Fields
                    rd.Fields(fd.Name) = fd.Value
                Next fd
                rd.Update
                rs.MoveNext
            Loop
            rd.Close
            Set rd = Nothing
            SysCmd acSysCmdRemoveMeter
            If bIdentity = True Then
                cn.Execute "SET IDENTITY_INSERT dbo.[" & sTableName & "] OFF"
            End If
            rs.Close
            Set rs = Nothing
        End If
    End If
    
    cn.Close
    Set cn = Nothing
    
    db.Close
    Set db = Nothing
    
    Set cat = Nothing
    cnDB.Close
    Set cnDB = Nothing

End Sub