Bill Benson
bensonforums at gmail.com
Fri Dec 26 19:18:58 CST 2014
I have written this routine (ReseedAll calls Reseed on each table that is
not a system table, one by one); The purpose is to resequence every
autonumber field while maintaining data integrity for all the other tables.
I believe it is reasonably robust. Where it is *not* robust is that I just
let it fail with suspended error handling, on the last part where I
re-build indexes, knowing that I have taken care of all unique keys *with
exception* of those Access-generated ones that occur in regards to
relations. The reason for that is that I am just too lazy and inexperienced
to figure out how to iterate through those. However, those are not the ones
preventing duplicates -- and since I never delete them from the database, I
don't produce no sweat about getting an error when "recreating" them.
I have tested this on my databases. If you are interested in using this
routine, I suggest that you make a backup of your own database before
trying it out.
Note that it only works (I think) on Fields / Foreign Keys that are long
integer. I don't think I even check for multi-key primary keys, so I don't
know what it will do to your database if you have multi-column PKs,
non-numeric PKs and FKs, and multi-column FKs. I wouldn't even try it out
if your database is in that condition.
(1) This is probably re-inventing the wheel, someone out there has a better
routine I am more than sure, such as Allen Browne and Roger Carlson. When I
get more energy I will compare this to other routines someone recommends I
check.
(2) Most here will inevitably begin to flame me saying that there is no
need to ever do this anyway, that the purpose of a PK is to be unique, and
it shouldn't matter if values are sequenced or not. Well, since I already
know that --- and this was just an exercised for the anal retentive and
obsessive compulsive... just let me alone please. Well, actually, say what
you want, just be sure to also let us know we can save 15% or more on car
insurance by switching to GEICO, and other things that everybody knows at
the same time - may as well cover all the bases!
(3) at the risk of being redundant, this is a "draft" version. If you want
to kick it around and see if it handles complex database, I would be glad
for advice about where it fails.
Sorry there are few comments. There's a metaphor for this kind of operation
... Towers of Hammurabi comes to mind, but that is not really the one. The
routine essentially checks the max PK value, kills indexes, copies all
records as duplicates deletes switches all the FK values in every other
table that refers to the subject table's PK (single-column) to the higher
number range, one-for-one, with Update queries. Seeds in the largest
autonumber value possible, 2147483647; seeds in 0 to get rid of negatives;
deletes records in the erstwhile lower PK range, duplicates all records
again so that PK sequence will again start with 1; does the swap of FK
values again in all tables that have the FKs to this table's PK, to the
lower range values; then deletes off the higher number range records,
before putting the indexes back on.
Final note: if the routine pauses with errors in the midst and you let
VarIndexes go out of state after indexes have been removed, you will lose
them. So one thing I will make more robust as a first priority is to store
all the index parameters in a table, so that I can more easily recover them
if there is a problem at runtime.
Option Compare Database
Option Explicit
Function ConcatenatePhone(Companyid As Long) As String
Dim R As DAO.Recordset
Dim D As DAO.Database
Set D = CurrentDb
Dim SQL As String
Dim strResult As String
' P.Phone,
' T.PhoneType
' from TblCompany As C inner Join
' (TblCompanyPhone as P
' inner join TblPhoneType as T on T.ID = P.FKPhoneTypeID)
on C.ID = P.FKCompanyID WHERE P.ID = 3
SQL = ""
SQL = SQL & " Select P.Phone, T.PhoneType "
SQL = SQL & " from TblCompany as C "
SQL = SQL & " inner Join (TblCompanyPhone as P "
SQL = SQL & " inner join TblPhoneType as T "
SQL = SQL & " on T.ID = P.FKPhoneTypeID)"
SQL = SQL & " on C.ID = P.FKCompanyID"
SQL = SQL & " WHERE C.ID = " & Companyid
Set R = D.OpenRecordset(SQL)
While Not R.EOF
strResult = strResult & "|" & R!PhoneType & ": " & R!Phone
R.MoveNext
Wend
If strResult <> "" Then
strResult = Mid(strResult, 2)
End If
ConcatenatePhone = strResult
End Function
''
''Function MyWholesaler() As Long
''MyWholesaler = CLng(Nz(Screen.ActiveForm.Controls("txtWholesaler"), 0))
''
''End Function
''Function MyRetailer() As Long
''MyRetailer = CLng(Nz(Screen.ActiveForm.Controls("txtRetailer"), 0))
''
''End Function
''
''Function MyMarketer() As Long
''MyMarketer = CLng(Nz(Screen.ActiveForm.Controls("txtMarketer"), 0))
''
''End Function
''
''
''
Sub findcontrol()
Dim Frm As Form
Dim ctrl As Control
Dim str As String
Set Frm = Screen.ActiveForm
For Each ctrl In Frm.Controls
str = ""
On Error Resume Next
str = ctrl.RowSource
If str <> "" Then
Debug.Print ctrl.Name & ": " & str
End If
Next
End Sub
Sub PositionCombo(Frm As Form, Ctr As String, iCol As Long, varValue As
Variant)
Dim ctrl As Control
Dim i As Long
Set ctrl = Frm.Controls(Ctr)
ctrl.Requery
For i = 0 To ctrl.ListCount - 1
If ctrl.Column(iCol, i) = CStr(varValue) Then
ctrl.Value = i
Exit For
End If
Next
End Sub
Sub ReseedAll()
Dim i As Long
Dim T As DAO.TableDef
Dim D As DAO.Database
Set D = CurrentDb
Dim VarTables() As String
ReDim VarTables(1 To D.TableDefs.Count) As String
For Each T In D.TableDefs
If UCase(Left(T.Name, 4)) <> "MSYS" And Left(T.Name, 1) <> "~" Then
i = i + 1
VarTables(i) = T.Name
End If
Next
For i = 1 To UBound(VarTables)
If VarTables(i) <> "" Then
Debug.Print VarTables(i)
'Stop
Reseed VarTables(i)
End If
Next
End Sub
Sub Reseed(strTable As String)
Dim Qdf As DAO.QueryDef
Dim Tdf As DAO.TableDef
Dim TdfDependent As DAO.TableDef
Dim D As DAO.Database
Dim iCol As Long
Dim Frm As Form
Dim i As Long
Dim iRelFields As Long
Dim R1 As DAO.Recordset
Dim R2 As DAO.Recordset
Dim R As DAO.Recordset
Dim FLD As DAO.Field
Dim strField As String
Dim strIndexFields As String
Dim strFields As String
Dim SQL As String
Dim iMax As Double
Dim Indx As Index
Dim iUnique As Long
Dim iRequired As Long
Set D = CurrentDb
Dim iUB As Long
Dim VarIndexes()
Dim VarFieldsTemp
Dim VarFields() As String
Dim Rel As Relation
Dim fldPK As DAO.Field
Dim strTempFields As String
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 D.QueryDefs
DoCmd.Close acQuery, Qdf.Name, acSaveYes
Next
For Each Tdf In D.TableDefs
DoCmd.Close acTable, Tdf.Name
Next
Set Tdf = D.TableDefs(strTable)
For Each FLD In Tdf.Fields
If FLD.Attributes And dbAutoIncrField Then
strField = FLD.Name
Else
strFields = strFields & ",[" & FLD.Name & "]"
End If
Next
Err.Clear
DoCmd.DeleteObject acTable, "Temp"
SQL = "Create Table [Temp] ([" & strField & "] Long)"
Err.Clear
D.Execute SQL, dbFailOnError
D.TableDefs.Refresh
If Err.Number <> 0 Then Stop
strFields = Mid(strFields, 2)
iMax = DMax("[" & strField & "]", strTable)
'Remove indexes else we might not be able to put in duplicate items
ReDim VarIndexes(1 To 4, 0 To 0)
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)
iUnique = Indx.Unique
iRequired = Indx.Required
iUB = UBound(VarIndexes, 2) + 1
If iUB = 1 Then
ReDim VarIndexes(1 To 4, 1 To iUB)
Else
ReDim Preserve VarIndexes(1 To 4, 1 To iUB)
End If
VarIndexes(1, iUB) = Indx.Name
VarIndexes(2, iUB) = strIndexFields
VarIndexes(3, iUB) = iUnique
VarIndexes(4, iUB) = iRequired
End If
Next
For i = UBound(VarIndexes, 2) To 1 Step -1
Tdf.Indexes.Delete VarIndexes(1, i)
Next
Tdf.Indexes.Refresh
'insert Duplicates
Err.Clear
SQL = "Insert Into [" & strTable & "] (" & strFields & ") Select " &
strFields & " from [" & strTable & "] order by [" & strField & "] Asc"
D.Execute SQL, dbFailOnError
If Err.Number <> 0 Then Stop
'Loop each dupe record, change fks everywhere to these replacement values
Set R1 = D.OpenRecordset("Select * from [" & strTable & "] WHERE [" &
strField & "] > " & iMax & " ORDER BY [" & strField & "] ASC")
R1.MoveFirst
Set R2 = D.OpenRecordset("Select * from [" & strTable & "] WHERE [" &
strField & "] <= " & iMax & " ORDER BY [" & strField & "] ASC")
R2.MoveFirst
While Not R1.EOF
On Error GoTo 0
For Each Rel In D.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
SQL = "Update [" & Rel.ForeignTable & "] Set [" &
Rel.Fields(iRelFields).ForeignName & "] = " & R1.Fields(strField) & " WHERE
[" & Rel.Fields(iRelFields).ForeignName & "] = " & R2.Fields(strField)
Err.Clear
D.Execute SQL, dbFailOnError
If Err.Number <> 0 Then Stop
End If
Next
Next
End If
Next
R1.MoveNext
R2.MoveNext
Wend
'Delete obsolete records
Err.Clear
D.Execute "Delete From [" & strTable & "] Where [" & strField & "] <=" &
iMax, dbFailOnError
If Err.Number <> 0 Then Stop
ReDim VarFieldsTemp(1 To 2, 0 To 0)
For Each Rel In D.Relations
If Rel.ForeignTable = strTable Then
SQL = "ALTER TABLE Temp ADD COLUMN [" & Rel.Fields(0).ForeignName &
"] Long"
Err.Clear
D.Execute SQL, 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
Err.Clear
D.Execute "Insert into [Temp] ([" & strField & "]) Values (" & 2147483647 &
")", dbFailOnError
If Err.Number <> 0 Then Stop
strTempFields = "[" & strField & "]"
'Put other required values in the table due to FKs in strTable
For i = 1 To UBound(VarFieldsTemp, 2)
strTempFields = strTempFields & ",[" & VarFieldsTemp(1, i) & "]"
SQL = "Update [Temp] Set [" & VarFieldsTemp(1, i) & "] = " &
VarFieldsTemp(2, i)
Err.Clear
D.Execute SQL, dbFailOnError
If Err.Number <> 0 Then Stop
Next
'Append this to our main table
Err.Clear
D.Execute "Insert Into [" & strTable & "] (" & strTempFields & ") Select "
& strTempFields & " From [Temp]", dbFailOnError
If Err.Number <> 0 Then Stop
'It was used so now we can remove it so we dont duplicate it
Err.Clear
SQL = "Update [Temp] Set [" & strField & "] = 0"
D.Execute SQL, dbFailOnError
If Err.Number <> 0 Then Stop
Err.Clear
D.Execute "Insert Into [" & strTable & "] (" & strTempFields & ") Select "
& strTempFields & " From [Temp]", dbFailOnError
If Err.Number <> 0 Then Stop
Err.Clear
D.Execute "Delete from [" & strTable & "] Where [" & strField & "] = " &
2147483647, dbFailOnError
If Err.Number <> 0 Then Stop
Err.Clear
D.Execute "Delete from [" & strTable & "] Where [" & strField & "] = " & 0,
dbFailOnError
If Err.Number <> 0 Then Stop
'From here on out all records should be 1, 2, ...
'Add the records in one more time so that they will sequence starting at 1
Err.Clear
D.Execute "Insert Into [" & strTable & "] (" & strFields & ") Select " &
strFields & " from [" & strTable & "] order by [" & strField & "] Asc",
dbFailOnError
If Err.Number <> 0 Then Stop
'Rerun the swap
Set R1 = D.OpenRecordset("Select * from [" & strTable & "] WHERE [" &
strField & "] > " & iMax & " ORDER BY [" & strField & "] ASC")
R1.MoveFirst
Set R2 = D.OpenRecordset("Select * from [" & strTable & "] WHERE [" &
strField & "] <= " & iMax & " ORDER BY [" & strField & "] ASC")
R2.MoveFirst
While Not R1.EOF
On Error GoTo 0
For Each Rel In D.Relations
Debug.Print Rel.Name
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
SQL = "Update [" & Rel.ForeignTable & "] Set [" &
Rel.Fields(iRelFields).ForeignName & "] = " & R2.Fields(strField) & " WHERE
[" & Rel.Fields(iRelFields).ForeignName & "] = " & R1.Fields(strField)
Err.Clear
D.Execute SQL, dbFailOnError
If Err.Number <> 0 Then Stop
End If
Next
Next
End If
Next
R1.MoveNext
R2.MoveNext
Wend
'Delete duplicates, those above iDesiredCount
Err.Clear
D.Execute "Delete from [" & strTable & "] Where [" & strField & "] > " &
iMax, dbFailOnError
If Err.Number <> 0 Then Stop
'Put back indexes after duplicates removed
Set Tdf = Nothing
Set R1 = Nothing
Set R2 = Nothing
For i = 1 To UBound(VarIndexes, 2)
' Set Indx = Tdf.CreateIndex(VarIndexes(1, i))
' VarFields = Split(VarIndexes(2, i), ",")
SQL = "CREATE " & IIf(CBool(VarIndexes(3, i)), " UNIQUE ", "") & "
Index " & VarIndexes(1, i) & " on [" & strTable & "] (" & VarIndexes(2, i)
& ")" & IIf(CBool(VarIndexes(4, i)), " WITH DISALLOW NULL;", ";")
On Error Resume Next
D.Execute SQL, dbFailOnError
'If Err.Number <> 0 Then Stop
Next
'D.Execute "CREATE UNIQUE INDEX CustID " _
& "ON Customers (CustomerID) " _
& "WITH DISALLOW NULL;"
Set FLD = Nothing
Set Tdf = Nothing
End Sub