'---------------------------------------------------------------------------------------
' Module    : bas_BanishIndexes
' Author    : Jim Doherty www.Bytes.com
' Date      : 05/07/2010
' Reference : http://bytes.com/topic/access/answers/890981-change-indexed-field-no
' Purpose   : To deal with three issues as requested on the forum
'1. to be able to change any indexed fields in a table to not indexed. for example.
'the fields are set as Indexed = Yes (No Duplicates) and i want them to be set as Indexed = No.
'2. I want to change all fields in a table that are AutoNumber to Number(long)
'3. I want to remove all primary keys from a table.

'Tested on Northwind database tables  and works ok! but test it out yourself on a spare copy  USE AT YOUR RISK!
'---------------------------------------------------------------------------------------
Option Explicit

Sub CreateTable_tblIndexes()
    On Error GoTo CreateTable_tblIndexes_Error
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim ind As DAO.Index

    Set db = CurrentDb()
    For Each tdf In db.TableDefs    'delete any pre-existing tblindex table
        If tdf.Name = "tblIndexes" Then db.TableDefs.Delete "tblIndexes"
    Next
    Set tdf = db.CreateTableDef("tblIndexes")
    With tdf
        Set fld = .CreateField("Row", dbLong)
        fld.Attributes = dbAutoIncrField + dbFixedField
        .Fields.Append fld
        .Fields.Append .CreateField("TableName", dbText, 100)
        .Fields.Append .CreateField("FieldCount", dbLong)
        .Fields.Append .CreateField("IndexName", dbText, 100)
        .Fields.Append .CreateField("Sequence", dbLong)
        .Fields.Append .CreateField("Primary", dbBoolean)
        .Fields.Append .CreateField("Unique", dbBoolean)
    End With
    db.TableDefs.Append tdf
    Set ind = tdf.CreateIndex("PrimaryKey")
    With ind
        .Fields.Append .CreateField("Row")
        .Unique = True
        .Primary = True
    End With
    tdf.Indexes.Append ind
    RefreshDatabaseWindow
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing

    On Error GoTo 0
    Exit Sub
CreateTable_tblIndexes_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
           ") in procedure CreateTable_tblIndexes of Module bas_BanishIndexes"
End Sub

Function DoIndexes(tbl, rstIndexes As Object)
    On Error GoTo DoIndexes_Error
    Dim idx As DAO.Index
    Dim Ctr As Integer  'counter (simply for sequencing)
    Ctr = 1
    BeginTrans
    For Ctr = 1 To tbl.Indexes.Count
        Set idx = tbl.Indexes(Ctr - 1)
        rstIndexes.AddNew
        rstIndexes!TableName = tbl.Name
        rstIndexes!FieldCount = tbl.Fields.Count
        rstIndexes!IndexName = idx.Name
        rstIndexes!Sequence = Ctr
        rstIndexes!Primary = idx.Primary
        rstIndexes!Unique = idx.Unique
        rstIndexes.Update
        '  wIdxCtr = wIdxCtr + 1
    Next Ctr
    CommitTrans
    Set idx = Nothing

    On Error GoTo 0
    Exit Function

DoIndexes_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
        ") in procedure DoIndexes of Module bas_BanishIndexes"
End Function

Function ExamineIndexes()
    On Error GoTo ExamineIndexes_Error
    Dim Mydb As DAO.Database
    Dim MyRS As DAO.Recordset
    Dim tbl As DAO.TableDef
    Dim rstIndexes As DAO.Recordset
    Dim MyFields As DAO.Recordset
    Dim MyField As DAO.Field
    Dim MyIndex As DAO.Index
    Dim MyIndexfields
    Dim strSQL As String
    Dim mystr As String, myndxstr As String
    Dim MyIndexunique
    Dim j As Long, cnt As Long
    Dim x

    Set Mydb = CurrentDb
    Set rstIndexes = Mydb.OpenRecordset("SELECT * FROM tblIndexes WHERE 1=2", dbOpenDynaset)
    BeginTrans
    SysCmd acSysCmdInitMeter, "Examining tables: ", CurrentDb.TableDefs.Count
    cnt = 1
    For Each tbl In CurrentDb.TableDefs
        SysCmd acSysCmdUpdateMeter, cnt
        If Left(tbl.Name, 4) <> "MSys" Then
            If tbl.Name <> "tblIndexes" Then
                x = DoIndexes(tbl, rstIndexes)
            End If

        End If
        cnt = cnt + 1
    Next tbl
    CommitTrans
    SysCmd acSysCmdRemoveMeter
    rstIndexes.Close
    Set rstIndexes = Nothing
    Set MyIndex = Nothing
    Set tbl = Nothing
    Set Mydb = Nothing
    strSQL = ""

    On Error GoTo 0
    Exit Function
ExamineIndexes_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
        ") in procedure ExamineIndexes of Module bas_BanishIndexes"
End Function

'---------------------------------------------------------------------------------------
' Procedure : BanishIndexes
' Author    : Jim Doherty
' Date      : 05/07/2010
' Purpose   : Run this from the immediate window simply type the Function name
            '    ?BanishIndexes
            'and hit enter   (You can if you wish assign the function to a button on a form up to you)
'           The procedure will call a routine to create a table inwhich is pumped table indexes
            'the table is ultimately traversed and relevant indexes dropped as outlined by the
            'contents of the table created called tblIndexes. The finale is a call to the function
            ''ed AUTOSTOLONG which looks for existing autonumber fields in all tables
            'if it finds one it creates a holding field and updates the contents from the autonumber
            'field. the original autonumber field is then dropped and recreated (cannot rename) and the
            'holding field then puts all the data back into the created  long integer field
'---------------------------------------------------------------------------------------
'
Function BanishIndexes()
    On Error GoTo BanishIndexes_Error
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim msg As String
    Set db = CurrentDb
    If CurrentDb.Relations.Count > 0 Then
        msg = "You have relationships defined in this database" & vbNewLine
        msg = msg & "You cannot drop primary keys unless you delete relationships" & vbNewLine & vbNewLine
        msg = msg & "Do you wish to delete them in order to use this procedure?"
        DoCmd.Beep
        If MsgBox(msg, vbQuestion + vbYesNo, "Drop Relationships") = vbYes Then
            DeleteRelationShips
        Else
            Exit Function
        End If
    End If
    CreateTable_tblIndexes    '<< create a table to store indexes so we have an 'after job done' reference
    ExamineIndexes  '<<< pump all table indexes into the created table
    'Now loop this tblIndexes table using it as a reference and delete the primary keys
    Set rs = db.OpenRecordset("tblIndexes", dbOpenSnapshot)
    Do While Not rs.EOF
        DBEngine(0)(0).TableDefs(rs!TableName).Indexes.Delete (rs!IndexName)
        rs.MoveNext
    Loop
    rs.Close
    AutosToLong
    MsgBox "Process Complete", vbInformation, "System Message"
    Set rs = Nothing
    Set db = Nothing
    On Error GoTo 0
    Exit Function
BanishIndexes_Error:
    If Err.Number = 3281 Then Resume Next    '<< 3281 is error for index used in relation
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
           ") in BanishIndexes of Module bas_BanishIndexes", vbExclamation, _
           "System Message"
End Function

'---------------------------------------------------------------------------------------
' Procedure : DeleteRelationShips
' Purpose   : Delete all relationships in the current database
'---------------------------------------------------------------------------------------
Function DeleteRelationShips()
    On Error Resume Next
    Dim rel As DAO.Relation
    For Each rel In CurrentDb.Relations
        CurrentDb.Relations.Delete rel.Name
    Next
End Function

'---------------------------------------------------------------------------------------
' Procedure : AutosToLong
' Purpose   : to change all autonumbers to long integer for all tables in the database
'---------------------------------------------------------------------------------------
Function AutosToLong()
    On Error GoTo AutosToLong_Error
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim MyField As String, msg As String
    Set db = CurrentDb
    msg = "Do you wish to change all 'Autonumber' fields to Number Long Integer?"
    If MsgBox(msg, vbQuestion + vbYesNo, "Change Autonumbers") = vbNo Then
        Exit Function
        For Each tdf In CurrentDb.TableDefs
            If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "tblIndexes" Then
                For Each fld In tdf.Fields
                    If CLng(fld.Type) = dbLong Then
                        If (fld.Attributes And dbAutoIncrField) = 0& Then
                            'it is a long integer so leave alone
                        Else
                            'it is an autonumber so convert by creating a field
                            'then updating it and dropping the original and recreating it
                            DoCmd.SetWarnings False

                            BeginTrans
                            tdf.Fields.Append tdf.CreateField("HoldingField", dbLong)
                            DoCmd.RunSQL "UPDATE " & tdf.Name & " SET HoldingField=" & fld.Name & ";"
                            MyField = fld.Name
                            tdf.Fields.Delete fld.Name
                            tdf.Fields.Append tdf.CreateField(MyField, dbLong)
                            DoCmd.RunSQL "UPDATE " & tdf.Name & " SET " & MyField & "=HoldingField;"
                            tdf.Fields.Delete "HoldingField"
                            CommitTrans
                            DoCmd.SetWarnings True
                        End If
                    End If
                Next fld
            End If
        Next tdf
    End If

    On Error GoTo 0
    Exit Function
AutosToLong_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
        ") in procedure AutosToLong of Module bas_BanishIndexes"
End Function