[AccessD] Resequence All Autonum Fields - a tentative approach

Bill Benson bensonforums at gmail.com
Sat Dec 27 14:23:16 CST 2014


I have written this routine ReseedAll.
The purpose is to resequence every autonumber field in the table.
If someone wants to kick its tires and see if it handles their complex
database, great - but I suggest making a backup (perhaps more than one!).

Order of steps:
1) checks the max PK value, make sure there is room to add all records
again without hitting
   Const HIGHEST_POSSIBLE_VALUE = 2147483647

2) Preserve indexes in a table, then delete them

3) Duplicate records so that there are equivalents in a higher range

4) Swap all values appearing in related tables that reference this table's
PK in their foreign key
   I am not sure if I handle multi-column FK references appropriately.

5) Delete the predecessor records from the table

6) Seeds in HIGHEST_POSSIBLE_VALUE = 2147483647 to the table; seed in 0 to
the table;

7) duplicates all records again, reusing the range 1, 2, 3 ... for PK

8) Swap all values appearing in related tables that reference this table's
PK in their foreign key
   I am not sure if I handle multi-column FK references appropriately.

9) Remove the no longer needed higher PK range of duplicate records

10) Replace indexes

Note1: The routine only works on Fields / Foreign Keys that are long
integer, and are autoincrementing (it tests).

Note2: No doubt others have created even more robust routines, this was my
1st attempt.

Note3: I will get flamed as creating something that serves no legitimate
purpose in the database. Oh well, everyone is entitled to their own set of
principles.

Note4: If the routine pauses with errors in the midst - that is for
debugging purposes; don't count on your database maintaining state... I
would fix the code and start again from backup.

Note5: There will be bypassed errors when indexes are stored and re-created
for those items which are bound up in relationships.

Code:
Sub Reseed(strTable As String)
Dim MyDB As DAO.Database, Tdf As DAO.TableDef, Qdf As DAO.QueryDef, Frm As
Form, Rel As Relation, Indx As Index
Dim Rst  As DAO.Recordset, rstHigherRange As DAO.Recordset, rstLowerRange
As DAO.Recordset, rstIndexes As DAO.Recordset
Dim iCol As Long
Dim i As Long, iTestNext As Long, iCount1 As Long, iCount2 As Long
Dim iRelFields As Long
Dim Fld As DAO.Field
Dim strPrimaryKeyField As String
Dim strIndexFields  As String
Dim strFields As String
Dim strSQL As String
Dim iUB As Long
Dim VarFieldsTemp
Dim VarFields() As String
Dim fldPK As DAO.Field
Dim strTempFields As String
Dim bPKFound As Boolean
Const HIGHEST_POSSIBLE_VALUE = 2147483647

Set MyDB = CurrentDb
'GoTo PutOnIndexes
If strTable = "Temp" Then Exit Sub
On Error Resume Next
For Each Frm In Forms
    DoCmd.Close acForm, Frm.Name, acSaveYes
Next
For Each Qdf In MyDB.QueryDefs
    DoCmd.Close acQuery, Qdf.Name, acSaveYes
Next
For Each Tdf In MyDB.TableDefs
    DoCmd.Close acTable, Tdf.Name
Next
Set Tdf = MyDB.TableDefs(strTable)
'Check PK has onlt one field
For Each Indx In Tdf.Indexes
    If Indx.Name = "PrimaryKey" Then
        If Indx.Fields.Count > 1 Then
            Debug.Print Tdf.Name & " Primary Key has " & Indx.Fields.Count
& " fields - cannot reseed " & strTable
            Exit Sub
        ElseIf Tdf.Fields(Indx.Fields(0).Name).Type <> dbLong Then
            Debug.Print Tdf.Name & " Primary Key field is not Type Long -
cannot reseed " & strTable
            Exit Sub
        ElseIf Tdf.Fields(Indx.Fields(0).Name).Attributes And
dbAutoIncrField Then
            strPrimaryKeyField = Indx.Fields(0).Name
            bPKFound = True
        Else
            Debug.Print Tdf.Name & " Primary Key field is not AutoNum -
cannot reseed " & strTable
            Exit Sub
        End If
        Exit For
    End If
Next
If Not bPKFound Then
    Debug.Print "No primary key was found - cannot reseed " & strTable
    Exit Sub
End If
'Test AddNew and make sure that there is enough room, before
highese_record_number, to add duplicates without resetting autonum field to
the negative range
Set Rst = MyDB.OpenRecordset("Select * from [" & strTable & "]")
Rst.MoveLast
i = Rst.RecordCount
Rst.AddNew
iTestNext = Rst.Fields(strPrimaryKeyField).Value
Rst.Cancel
If i + iTestNext > HIGHEST_POSSIBLE_VALUE - 1 Then
    Debug.Print "Highest record number already used is too high to perform
this operation on " & strTable
    Exit Sub
End If
Set Rst = Nothing
'Get all the other fields so that append query will add all fields for
duplicate entry
For Each Fld In Tdf.Fields
    If Fld.Name <> strPrimaryKeyField Then
        strFields = strFields & ",[" & Fld.Name & "]"
    End If
Next
strFields = Mid(strFields, 2)
Err.Clear
DoCmd.DeleteObject acTable, "Temp"
strSQL = "Create Table [Temp] ([" & strPrimaryKeyField & "] Long)"
Err.Clear
MyDB.Execute strSQL, dbFailOnError
MyDB.TableDefs.Refresh
If Err.Number <> 0 Then Stop

'Remove indexes else we might not be able to put in duplicate items
Set rstIndexes = Nothing
DoCmd.DeleteObject acTable, "Temp_RetainIndexes"
strSQL = "Create Table [Temp_RetainIndexes] ("
strSQL = strSQL & "[TheName] TEXT(255)"
strSQL = strSQL & ",[TheFields] TEXT(255)"
strSQL = strSQL & ",IsUnique YESNO"
strSQL = strSQL & ",IsRequired YESNO"
strSQL = strSQL & ")"
Err.Clear
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop
MyDB.TableDefs.Refresh
For Each Indx In Tdf.Indexes
    If Indx.Name <> "PrimaryKey" Then
        strIndexFields = ""
        For Each Fld In Indx.Fields
            strIndexFields = strIndexFields & ",[" & Fld.Name & "]"
        Next
        strIndexFields = Mid(strIndexFields, 2)
        strSQL = "Insert Into "
        strSQL = strSQL & "Temp_RetainIndexes"
        strSQL = strSQL & " (TheName,"
        strSQL = strSQL & "TheFields,"
        strSQL = strSQL & "IsUnique,"
        strSQL = strSQL & "IsRequired)"
        strSQL = strSQL & " Values ("
        strSQL = strSQL & "'" & Indx.Name & "'"
        strSQL = strSQL & ", '" & strIndexFields & "'"
        strSQL = strSQL & ", " & Indx.Unique
        strSQL = strSQL & ", " & Indx.Required
        strSQL = strSQL & ")"
        Err.Clear
        MyDB.Execute strSQL, dbFailOnError
        If Err.Number <> 0 Then Stop
    End If
Next
'Now remove all stored indexes from the table
Set rstIndexes = MyDB.OpenRecordset("Select * from [Temp_RetainIndexes]")
If Not rstIndexes.EOF Then
    rstIndexes.MoveFirst
    Do
        Err.Clear
        Tdf.Indexes.Delete rstIndexes!TheName
        If Err.Number <> 0 Then
            Debug.Print Err.Description, rstIndexes!TheName
        End If
        rstIndexes.MoveNext
    Loop Until rstIndexes.EOF
End If
Tdf.Indexes.Refresh
Set rstIndexes = Nothing
'Duplicate every row in the table
Err.Clear
strSQL = "Insert Into [" & strTable & "] ("
strSQL = strSQL & strFields & ")"
strSQL = strSQL & " Select "
strSQL = strSQL & strFields
strSQL = strSQL & " FROM [" & strTable & "]"
strSQL = strSQL & " ORDER BY [" & strPrimaryKeyField & "] Asc"
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop
'Loop each dupe record, change fks everywhere to these replacement values
strSQL = "Select * "
strSQL = strSQL & " FROM [" & strTable & "] "
strSQL = strSQL & " WHERE [" & strPrimaryKeyField & "] > " & iTestNext
strSQL = strSQL & " ORDER BY [" & strPrimaryKeyField & "] ASC"
Set rstHigherRange = MyDB.OpenRecordset(strSQL)
rstHigherRange.MoveLast
iCount1 = rstHigherRange.RecordCount
strSQL = "Select * "
strSQL = strSQL & " FROM [" & strTable & "] "
strSQL = strSQL & " WHERE [" & strPrimaryKeyField & "] < " & iTestNext
strSQL = strSQL & " ORDER BY [" & strPrimaryKeyField & "] ASC"
Set rstLowerRange = MyDB.OpenRecordset(strSQL)
rstLowerRange.MoveLast
iCount2 = rstLowerRange.RecordCount
If iCount1 = 0 Or (iCount1 <> iCount2) Then
    Debug.Print "Could not create an equal number of records in " &
strTable & ", could not reseed " & strTable
    strSQL = "Delete * from [" & strTable & "] Where [" &
strPrimaryKeyField & "] >" & iTestNext
    Err.Clear
    MyDB.Execute strSQL, dbFailOnError
    If Err.Number <> 0 Then Stop
    Exit Sub
End If
rstLowerRange.MoveFirst
rstHigherRange.MoveFirst
'Set all values for the reference field in the related table to the value
we have sublimated the primary key field value to in the main table
Do Until rstHigherRange.EOF
    For Each Rel In MyDB.Relations
        If Rel.Table = Tdf.Name Then
            For iRelFields = 0 To Rel.Fields.Count - 1
                For Each fldPK In Tdf.Indexes("PrimaryKey").Fields
                    If Rel.Fields(iRelFields).Name = fldPK.Name Then
                        strSQL = "Update [" & Rel.ForeignTable & "]"
                        strSQL = strSQL & " Set [" &
Rel.Fields(iRelFields).ForeignName & "] = "
                        strSQL = strSQL &
rstHigherRange.Fields(strPrimaryKeyField)
                        strSQL = strSQL & " WHERE "
                        strSQL = strSQL & " [" &
Rel.Fields(iRelFields).ForeignName & "] = " &
rstLowerRange.Fields(strPrimaryKeyField)
                        Err.Clear
                        MyDB.Execute strSQL, dbFailOnError
                        If Err.Number <> 0 Then Stop
                    End If
                Next
            Next
        End If
    Next
    rstHigherRange.MoveNext
    rstLowerRange.MoveNext
Loop
'Delete predecessor records now that the tables which refer to them have
all been updated
strSQL = "Delete From [" & strTable & "] "
strSQL = strSQL & " Where [" & strPrimaryKeyField & "] < " & iTestNext
Err.Clear
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop
'The next routine makes sure that there is a valid value from each table
that strTable has a foreign key to,
'that we may use as dummy values in all the required fields in strTable...
otherwise we could not append
'dummy records with highest_record_number and 0 from the Temp table into
strTable
ReDim VarFieldsTemp(1 To 2, 0 To 0)
For Each Rel In MyDB.Relations
    If Rel.ForeignTable = strTable Then
        strSQL = "ALTER TABLE Temp ADD COLUMN [" &
Rel.Fields(0).ForeignName & "] Long"
        Err.Clear
        MyDB.Execute strSQL, dbFailOnError
        If Err.Number <> 0 Then Stop
        iUB = UBound(VarFieldsTemp, 2) + 1
        If iUB = 1 Then
            ReDim VarFieldsTemp(1 To 2, 1 To iUB)
        Else
            ReDim Preserve VarFieldsTemp(1 To 2, 1 To iUB)
        End If
        VarFieldsTemp(1, iUB) = Rel.Fields(0).ForeignName
        VarFieldsTemp(2, iUB) = DMin("[" & Rel.Fields(0).Name & "]",
Rel.Table)
    End If
Next
'insert the highest possible recordid
strSQL = "Insert into [Temp] ("
strSQL = strSQL & "[" & strPrimaryKeyField & "]) Values (" &
HIGHEST_POSSIBLE_VALUE & ")"
Err.Clear
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop
'Update the other fields with valid values from related tables which
strTable has foreign keys to
strTempFields = "[" & strPrimaryKeyField & "]"
'Put other required values in the table due to FKs in strTable
For i = 1 To UBound(VarFieldsTemp, 2)
    strTempFields = strTempFields & ",[" & VarFieldsTemp(1, i) & "]"
    strSQL = "Update [Temp] Set [" & VarFieldsTemp(1, i) & "] = " &
VarFieldsTemp(2, i)
    Err.Clear
    MyDB.Execute strSQL, dbFailOnError
    If Err.Number <> 0 Then Stop
Next
'Append this dummy record with highest possible record value to strTable
Err.Clear
MyDB.Execute "Insert Into [" & strTable & "] (" & strTempFields & ") Select
" & strTempFields & " From [Temp]", dbFailOnError
If Err.Number <> 0 Then Stop
'Now insert a record starting at zero so that when we re-add all records
advanced to higher pk sequence back to strTable, they start at 1
strSQL = "Update [Temp] Set [" & strPrimaryKeyField & "] = 0"
Err.Clear
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop
'Re-add all strTables records to itself
Err.Clear
MyDB.Execute "Insert Into [" & strTable & "] (" & strTempFields & ") Select
" & strTempFields & " From [Temp]", dbFailOnError
If Err.Number <> 0 Then Stop
'Clear the two dummy records
strSQL = "Delete from [" & strTable & "] Where [" & strPrimaryKeyField & "]
In (0, " & HIGHEST_POSSIBLE_VALUE & ")"
Err.Clear
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop

'From here on out all records should be 1, 2 when they are added
'Add the records in one more time so that they will sequence starting at 1
Err.Clear
MyDB.Execute "Insert Into [" & strTable & "] (" & strFields & ") Select " &
strFields & " from [" & strTable & "] order by [" & strPrimaryKeyField & "]
Asc", dbFailOnError
If Err.Number <> 0 Then Stop
'Let's test
If DCount("[" & strPrimaryKeyField & "]", strTable, "[" &
strPrimaryKeyField & "] <" & iTestNext & " And [" & strPrimaryKeyField & "]
> 0") = DCount("[" & strPrimaryKeyField & "]", strTable, "[" &
strPrimaryKeyField & "] >" & iTestNext) Then
    Debug.Print "Reseed successful, range of [" & strPrimaryKeyField & "]
in [" & strTable & "] is now from " & DMin("[" & strPrimaryKeyField & "]",
strTable, "[" & strPrimaryKeyField & "] <" & iTestNext & " and [" &
strPrimaryKeyField & "] >0") & " to " & DMax("[" & strPrimaryKeyField &
"]", strTable, "[" & strPrimaryKeyField & "] <" & iTestNext)
Else
    Debug.Print "Reseed unsuccessful, the count of records is off"
    Stop
End If
'Prepare to do the final swap
strSQL = "Select * from [" & strTable & "] "
strSQL = strSQL & " WHERE [" & strPrimaryKeyField & "] > " & iTestNext
strSQL = strSQL & " ORDER BY [" & strPrimaryKeyField & "] ASC"
Set rstHigherRange = MyDB.OpenRecordset(strSQL)
rstHigherRange.MoveLast
iCount1 = rstHigherRange.RecordCount
strSQL = "Select * from [" & strTable & "] "
strSQL = strSQL & " WHERE [" & strPrimaryKeyField & "] < " & iTestNext
strSQL = strSQL & " ORDER BY [" & strPrimaryKeyField & "] ASC"
Set rstLowerRange = MyDB.OpenRecordset(strSQL)
rstLowerRange.MoveLast
iCount2 = rstLowerRange.RecordCount
If iCount1 = 0 Or (iCount1 <> iCount2) Then
    Debug.Print "Could not create an equal number of records in " &
strTable & ", or else sequencing failed - could not reseed " & strTable
    strSQL = "Delete * from [" & strTable & "] Where [" &
strPrimaryKeyField & "] <" & iTestNext
    Err.Clear
    MyDB.Execute strSQL, dbFailOnError
    If Err.Number <> 0 Then Stop
    Exit Sub
End If
rstLowerRange.MoveFirst
rstHigherRange.MoveFirst
'Rerun the swap
Do Until rstHigherRange.EOF
    For Each Rel In MyDB.Relations
        If Rel.Table = Tdf.Name Then
            For iRelFields = 0 To Rel.Fields.Count - 1
                For Each fldPK In Tdf.Indexes("PrimaryKey").Fields
                    If Rel.Fields(iRelFields).Name = fldPK.Name Then
                        strSQL = "Update [" & Rel.ForeignTable & "] "
                        strSQL = strSQL & "Set [" &
Rel.Fields(iRelFields).ForeignName & "] = " &
rstLowerRange.Fields(strPrimaryKeyField)
                        strSQL = strSQL & " WHERE [" &
Rel.Fields(iRelFields).ForeignName & "] = " &
rstHigherRange.Fields(strPrimaryKeyField)
                        Err.Clear
                        MyDB.Execute strSQL, dbFailOnError
                        If Err.Number <> 0 Then Stop
                    End If
                Next
            Next
        End If
    Next
    rstHigherRange.MoveNext
    rstLowerRange.MoveNext
Loop
'Delete the duplicates left in the higher range, those above iMax
strSQL = "Delete from [" & strTable & "] Where [" & strPrimaryKeyField & "]
> " & iTestNext
Err.Clear
MyDB.Execute strSQL, dbFailOnError
If Err.Number <> 0 Then Stop
'Put back indexes after duplicates removed
Set Fld = Nothing
Set Tdf = Nothing
Set Rst = Nothing
Set rstHigherRange = Nothing
Set rstLowerRange = Nothing
Set Rst = Nothing
PutOnIndexes:
Set rstIndexes = MyDB.OpenRecordset("Select * from [Temp_RetainIndexes]")
If Not rstIndexes.EOF Then
    rstIndexes.MoveFirst
    On Error Resume Next
    Do Until rstIndexes.EOF
        strSQL = "CREATE "
        strSQL = strSQL & IIf(CBool(rstIndexes!IsUnique), " UNIQUE ", "")
        strSQL = strSQL & " Index "
        strSQL = strSQL & rstIndexes!TheName
        strSQL = strSQL & " on "
        strSQL = strSQL & "[" & strTable & "] "
        strSQL = strSQL & "(" & rstIndexes!TheFields & ")"
        strSQL = strSQL & IIf(CBool(rstIndexes!IsRequired), " WITH DISALLOW
NULL", "")
        strSQL = strSQL & ";"
        'We don't worry about errors here because we know that the ones
related to relations were never going to be deletable anyway
        Err.Clear
        MyDB.Execute strSQL, dbFailOnError
        Debug.Print Err.Description
        rstIndexes.MoveNext
    Loop
End If
Set rstIndexes = Nothing
End Sub


More information about the AccessD mailing list