Option Compare Database
Option Explicit

'.Comments  : There is a new "feature" starting in Jet 4.0 SP4, wherein Autonumber fields are not reset after a Compact
'               operation on an mdb.  Until now, when you compact an mdb, all autonumbers are cleared and reset to the
'               next consecutive number following the max value in the field.  From Jet 4.0 SP4, onward, this is no longer
'               the case.  Suggested workarounds include deleting all records in tables you want reset, and then compacting
'               the mdb and deleting and re-creating Autonumber fields on tables (which requires deleting and re-creating
'               relationships as well).  Neither of these appealed to me, so I looked for a better solution.
'
'             MSKB article Q287756 includes a function called ChangeSeed, which takes as parameters a table, field, and new
'               seed value.  The seed is the value you want to update the next Autonumber value to.  I took this function and
'               generalized it.  My version allows you to enter the full path to any mdb, and optionally a username and password
'               to open it with.  It creates an ADO connection to that mdb, iterates through all the tables it contains, and
'               resets all the Autonumbers just like Compact used to.
'
'             My function makes a couple of assumptions.  First, it assumes the target database is a Jet database (eg a
'               standard mdb file).  Second, it assumes that each table only has one Autonumber field.  It shou;d be noted
'               that I am firmly in the Artificial Primary Key camp, and exclusively use Autonumber fields for all Primary
'               Keys in all tables all the time.  OK, occasionally I use a Long Integer, but never a "real" data field
'               as a Primary Key.  This means that all my tables will only ever have at most one Autonumber field.  Until I
'               stop using Access as a database platform, this is how I will do things.  If your tables may contain more
'               than one Autonumber field, it would be very easy to modify the code to handle them all.  I chose not to do so
'               here in an effort to speed things up a bit.
'
'             Questions or comments may be sent to sgsax@ksu.edu.  I hope you enjoy it!  -Seth
'
'.Parameters: strMDB - the full path to the mdb you want to reset
'             strUser (Optional) - a username to access the mdb with
'             strPassword (Optional) - a password to access the mdb with
'.Sets      :
'.Returns   : success (True) or failure (False)
'.Created by: Seth D. Galitzer
'.Created   : 7/30/2003 12:01:08 AM
Function ResetAllAutoNumbers(strMDB As String, Optional strUser As String, Optional strPassword As String) As Boolean
On Error GoTo Err_ResetAllAutoNumbers
    Dim cnn As ADODB.Connection
    Dim cat As New ADOX.Catalog
    Dim col As ADOX.Column
    Dim tbl As ADOX.Table
    Dim strConn As String
    Dim lngSeed As Long
    Dim bFlag As Boolean
    
    bFlag = True                                                    'initialize the error flag
    
    'assemble the connection string
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strMDB & ";"
    If strUser <> "" Then strConn = strConn & "User ID=" & strUser & ";"
    If strPassword <> "" Then strConn = strConn & "Password=" & strPassword & ";"
    
    'Set connection and catalog to the specified database.
    Set cnn = New ADODB.Connection
    cnn.Open strConn
    cat.ActiveConnection = cnn
    
    For Each tbl In cat.Tables                                      'iterate all tables
        For Each col In tbl.Columns                                 'iterate all columns in each table
            If col.Properties("Autoincrement") = True Then          'stop when we get to an autonumber column
                lngSeed = basGetMax(cnn, tbl.Name, col.Name) + 1    'determine what the next seed should be
                col.Properties("Seed") = lngSeed                    'set the proper seed value
                tbl.Columns.Refresh                                 'refresh the columns collection for the current table
                If col.Properties("Seed") <> lngSeed Then bFlag = False     'if it didn't work any given time, then raise the flag
                Exit For                                            'assume there are no more autonumber fields and break out of the loop
            End If
        Next col
    Next tbl

    
Exit_ResetAllAutoNumbers:
    ResetAllAutoNumbers = bFlag
On Error Resume Next
    'garbage cleanup
    If Not (tbl Is Nothing) Then Set tbl = Nothing
    If Not (col Is Nothing) Then Set col = Nothing
    If Not (cat Is Nothing) Then Set cat = Nothing
    If Not (cnn Is Nothing) Then cnn.Close: Set cnn = Nothing
Exit Function
Err_ResetAllAutoNumbers:
    Select Case Err
    Case 0      '.insert Errors you wish to ignore here
        Resume Next
    Case Else   '.All other errors will trap
        Beep
        MsgBox Err.Description, , "Error in Function modRepair.ResetAllAutoNumbers"
        bFlag = False
        Resume Exit_ResetAllAutoNumbers
    End Select
    Resume 0    '.FOR TROUBLESHOOTING
End Function
                
'.Comments  : I needed the functionality of DMax on a remote table.  This function provides that functionality.  It can be
'               moved and used anywhere, just os long as the connection object is already set and passed in to it.  It
'               could easily be modified to handle creation of the connection internally.
'.Parameters: cnn - the ADO connection which contains the desired recordset
'             strTable - the name of the table you want to search in
'             strField - the field which contains data from wich you want to find the max value
'.Sets      :
'.Returns   : the max value from the selected field, 0 if the recordset is empty, or -1 if an error occurred
'.Created by: Seth D. Galitzer
'.Created   : 7/30/2003 12:27:12 AM
Private Function basGetMax(cnn As Connection, strTable As String, strField As String) As Long
On Error GoTo Err_basGetMax
    Dim rst As ADODB.Recordset
    Dim strSQL As String
    
    strSQL = "SELECT Max(" & strField & ") as fldMax FROM " & strTable      'build the recordset SQL string
    Set rst = New ADODB.Recordset
    rst.Open strSQL, cnn                                                    'open the recordset
    rst.MoveFirst                                                           'there should only be one record
    basGetMax = NtoZ(rst("fldMax").Value)                                   'return 0 or the correct max value
    
Exit_basGetMax:
On Error Resume Next
    If Not (rst Is Nothing) Then rst.Close: Set rst = Nothing               'clean up variabled
Exit Function
Err_basGetMax:
    Select Case Err
    Case 0      '.insert Errors you wish to ignore here
        Resume Next
    Case Else   '.All other errors will trap
        Beep
        MsgBox Err.Description, , "Error in Function modRepair.basGetMax"
        basGetMax = -1                                                      'an error occurred, return -1 for failure
        Resume Exit_basGetMax
    End Select
    Resume 0    '.FOR TROUBLESHOOTING
End Function

'.Comments  : My own Null-to-Zero function.  This one only returns a Long Integer.  It could easily be modified to return
'               a Double or Single value.
'.Parameters: varValue - the value to be evaluated
'.Sets      :
'.Returns   : 0 if value is null, or the value converted to a long integer
'.Created by: Seth D. Galitzer
'.Created   : 7/30/2003 12:32:51 AM
Private Function NtoZ(varValue As Variant) As Long
On Error GoTo Err_NtoZ
    If IsNull(varValue) Then
        NtoZ = 0
    Else
        NtoZ = CLng(varValue)
    End If
Exit_NtoZ:
Exit Function
Err_NtoZ:
    Select Case Err
    Case 0      '.insert Errors you wish to ignore here
        Resume Next
    Case Else   '.All other errors will trap
        Beep
        MsgBox Err.Description, , "Error in Function modRepair.NtoZ"
        Resume Exit_NtoZ
    End Select
    Resume 0    '.FOR TROUBLESHOOTING
End Function