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