Urgent - Find name of index field in ADO

You have a problem in that ADO works is supposed to work with many back-end servers. But they forgot to make autonunber/counter/identity fields easy.

Are you using Access back-end or SQL server or what?

As you will be aware each table must have a primary key or ADO won't allow updates.

Here is some code that will find all details for a table.  The Function will pull out all details for a table in a format that you can paste into excel so see which bits you need.

If you are using MDB's you need to add a reference to ADOX, ADO's Securty Extension.

The code to handle ADOX is commented at the base of the subroutine.

The fucntion came from a class with many other functions I hope it works a stand alone function.

If you get any problems please inform me.

Public Function GetSchemas(CN As ADODB.Connection, Optional TableName As String) As String

' Returns all of the scheme stuff for a table
' example.
' Clipboard.Clear : Clipboard.SetText ADO.GetSchemas(CN, "MyTable")


Dim SQL As String
Dim RS As ADODB.Recordset
Dim m$
Dim lc As Long
Dim ok
Dim Flags As Long
Dim bn As String
ReDim bin(8) As Long
Dim ctype As String
Dim tb As String

bin(1) = 1
bin(2) = 2
bin(3) = 4
bin(4) = 8
bin(5) = 16
bin(6) = 32
bin(7) = 64
bin(8) = 128

'TABLE_CATALOG
'TABLE_SCHEMA
'INDEX_NAME
'TYPE
'TABLE_NAME


tb = TableName


'adSchemaPrimaryKeys
'adSchemaColumns
'adSchemaIndexes

m$ = "TABLE:" + Chr$(9) + TableName + vbCrLf

Dim desc$

ctype = "TABLES": desc = "adSchemaTables": GoSub GetDets
ctype = "COLS": desc = "adSchemaColumns": GoSub GetDets
ctype = "PKEYS": desc = "adSchemaPrimayKeys": GoSub GetDets
ctype = "INDEX": desc = "adSchemaIndexes": GoSub GetDets
ctype = "IDENT": desc = "adSchemaIndexes": GoSub GetIdent

GetSchemas = m$

Exit Function

GetDets:

m$ = m$ + vbCrLf + desc + vbCrLf + vbCrLf

Select Case ctype
    Case Is = "COLS"
        Set RS = CN.OpenSchema(adSchemaColumns, Array(Empty, Empty, tb, Empty))
    Case Is = "TABLES"
        Set RS = CN.OpenSchema(adSchemaTables, Array(Empty, Empty, TableName))
    Case Is = "PKEYS"
        Set RS = CN.OpenSchema(adSchemaPrimaryKeys, Array(Empty, Empty, TableName))
    Case Is = "INDEX"
        Set RS = CN.OpenSchema(adSchemaIndexes, Array(Empty, Empty, Empty, Empty, tb))
End Select

SQL = Space$(2)

For lc = 0 To RS.Fields.Count - 1
    If lc > 0 Then m$ = m$ + Chr$(9)
    m$ = m$ + CStr(RS.Fields(lc).Name)
Next lc

If ctype = "COLS" Then
    For lc = 1 To 8
        m$ = m$ + Chr(9) + "Flag:" + CStr(bin(lc))
    Next lc
End If

m$ = m$ + vbCrLf

Do While Not RS.EOF

    For lc = 0 To RS.Fields.Count - 1
        If lc > 0 Then m$ = m$ + Chr$(9)
        m$ = m$ + Format(RS.Fields(lc))
    Next lc
   
    If ctype = "COLS" Then
        Flags = RS.Fields("COLUMN_FLAGS")
        bn = String(8, "0")
        For lc = 1 To 8
            If Flags And bin(lc) Then
                Mid(bn, lc, 1) = "1"
            End If
            m$ = m$ + Chr(9) + Mid(bn, lc, 1)
        Next lc
    End If
   
    m$ = m$ + vbCrLf
   
    RS.MoveNext
   
Loop

m$ = m$ + vbCrLf

If False Then

    m$ = m$ + vbCrLf
    RS.Close
   
  '  ok = ADO.OpenRSROOK(CN, RS, "Select * from " + tb + ";")
    For lc = 0 To RS.Fields.Count - 1
        m$ = m$ + CStr(RS.Fields(lc).Name) + Chr(9)
        m$ = m$ + CStr(RS.Fields(lc).Type) + vbCrLf
    Next lc
   
    m$ = m$ + vbCrLf
   
    RS.Close
End If

Return


GetIdent:

If False Then ' this only works for SQL server
    SQL = "SELECT  IDENT_SEED(TABLE_NAME) As Seed,"
    SQL = SQL + " IDENT_INCR(TABLE_NAME) AS Increment,"
    SQL = SQL + " TABLE_NAME"
    SQL = SQL + " From INFORMATION_SCHEMA.TABLES"
    SQL = SQL + " WHERE ((TABLE_NAME='" + tb + "')"
    SQL = SQL + " And (OBJECTPROPERTY(OBJECT_ID(TABLE_NAME), 'TableHasIdentity') = 1)"
    SQL = SQL + " AND (TABLE_TYPE = 'BASE TABLE'))"
    On Error Resume Next
    ok = True
    Set RS = CN.Execute(SQL)
    If Err.Number <> 0 Then
        ok = False
    Else
        If RS.EOF Then
            ok = False
            Set RS = Nothing
        End If
    End If
    If Not ok Then
        m$ = m$ + vbCrLf + vbCrLf + "No SQL Server identity field details available."
    Else
        m$ = m$ + vbCrLf + vbCrLf + "SQL Identity field details:"
        m$ = m$ + "Identity Seed: " + CStr(RS("Seed")) + vbCrLf
        m$ = m$ + "Identity Increment: " + CStr(RS("Increment")) + vbCrLf
        m$ = m$ + vbCrLf
        Set RS = Nothing
    End If
End If


Return

' If using MDB change the above to the following:

 '       Set aCat = New ADOX.Catalog
 '       aCat.ActiveConnection = CN
 '       Set aTab = aCat.Tables(TableName)
 '       For Each aCol In aTab.Columns
 '           If aCol.Properties("AutoIncrement") = True Then
 '               IdentityName = aCol.Name
 '               IdentitySeed = aCol.Properties("Seed")
 '               IdentityIncrement = aCol.Properties("Increment")
 '               Exit For
 '           End If
 '       Next
 '       Set aCol = Nothing
 '       Set aTab = Nothing
 '       Set aCat = Nothing
       
End Function

I enhanced the bit of code following GetIdent.  


GetIdent:

    Dim aCat As adox.Catalog
    Dim aTab As adox.Table
    Dim aCol As adox.Column
    Dim IdentityName As String
    Dim IdentitySeed As Long
    Dim IdentityIncrement As Long

If True Then ' change to false if using MDB as this only works for SQL server
   
    SQL = "SELECT  t.TABLE_NAME, c.name AS COLUMN_NAME, IDENT_SEED(t.TABLE_NAME) As Seed, IDENT_INCR(t.TABLE_NAME) As Increment"
    SQL = SQL + " From INFORMATION_SCHEMA.TABLES AS t INNER JOIN sysobjects AS s ON s.name = t.TABLE_NAME"
    SQL = SQL + " INNER JOIN syscolumns AS c ON c.id = s.id"
    SQL = SQL + " Where ((t.TABLE_NAME='" + TableName + "')"
    SQL = SQL + " And (OBJECTPROPERTY(OBJECT_ID(t.TABLE_NAME), 'TableHasIdentity') = 1)"
    SQL = SQL + " AND (t.TABLE_TYPE = 'BASE TABLE')) AND c.autoval IS NOT NULL"
    On Error Resume Next
    ok = False
    Set RS = CN.Execute(SQL)
    If Err.Number <> 0 Then
        ' must be MDB file
    Else
        If RS.EOF Then
            Set RS = Nothing
        Else
            ok = True
            IdentitySeed = ADO.GitNum(RS("Seed"))
            IdentityIncrement = ADO.GitNum(RS("Increment"))
            IdentityName = ADO.Git(RS("COLUMN_NAME"))
        End If
    End If

Else


   
    ' If using MDB change the above to the following:

    Set aCat = New adox.Catalog
    aCat.ActiveConnection = CN
    Set aTab = aCat.Tables(TableName)
    ok = False
    For Each aCol In aTab.Columns
        If aCol.Properties("AutoIncrement") = True Then
            IdentityName = aCol.Name
            IdentitySeed = aCol.Properties("Seed")
            IdentityIncrement = aCol.Properties("Increment")
            ok = True
           
           
            Exit For
        End If
    Next
    Set aCol = Nothing
    Set aTab = Nothing
    Set aCat = Nothing
End If

If Not ok Then
    m$ = m$ + vbCrLf + vbCrLf + "No identity field details available."
Else
    m$ = m$ + vbCrLf + vbCrLf + "SQL Identity field details:"
    m$ = m$ + "Identity Name: " + RS("COLUMN_NAME") + vbCrLf
    m$ = m$ + "Identity Seed: " + CStr(RS("Seed")) + vbCrLf
    m$ = m$ + "Identity Increment: " + CStr(RS("Increment")) + vbCrLf
    m$ = m$ + vbCrLf
    Set RS = Nothing
End If

Return

That worked well, thanks