Creating table relationships with code

Question

I am taken reference from Mr. Allen code posted in the below link

https://bytes.com/topic/access/answers/201110-creating-table-relationships-code 

To create relationship, I pasted the below code on a command button click, but no error and no relationship gets created on the first time click, so closed the database and open again and tried then error gets produced, while as show below

Please check and advise what correction is required

The code is :

Private Sub Command0_Click()

Dim db As DAO.Database

Dim rel As DAO.Relation

Dim fld As DAO.Field

'Initialize

Set db = CurrentDb()

'Create a new relation.

Set rel = db.CreateRelation("MyMainTableMyRelatedTable")

'Define its properties.

With rel

'Specify the primary table.

.Table = "AttnTabA"

'Specify the related table.

.ForeignTable = "AttnTabB"

'Specify attributes for cascading updates and deletes.

.Attributes = dbRelationUpdateCascade + dbRelationDeleteCascade

'Add the fields to the relation.

'Field name in primary table.

Set fld = .CreateField("FormNo")

'Field name in related table.

fld.ForeignName = "FormNo" 'Please note that primary table field name & forieign field name i kept same

'Append the field.

.Fields.Append fld

'Repeat for other fields if a multi-field relation.

End With

'Save the newly defined relation to the Relations collection.

db.Relations.Append rel

'Clean up

Set fld = Nothing

Set rel = Nothing

Set db = Nothing

Debug.Print "Relation created."

End Sub

error dailog

Answer 1

Strange - the documentation states that the Name argument of CreateRelation is optional.

Try the following.

Sub DoARelation()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim rel As DAO.Relation
    Dim fld As DAO.Field
    Dim i As Long
    On Error Resume Next
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("TblAlterRelation", dbOpenForwardOnly)
    Do While Not rst.EOF
        'Create a new relation.
        i = i + 1
        Set rel = dbs.CreateRelation("Relation" & i)
        'Define its properties.
        With rel
            'Specify the primary table.
            .Table = rst!MainTableName
            'Specify the related table.
            .ForeignTable = rst!FTableName
            'Specify attributes for cascading updates and deletes.
            .Attributes = dbRelationUpdateCascade + dbRelationDeleteCascade
            'Add the fields to the relation.
            'Field name in primary table.
            Set fld = .CreateField(rst!MainTablePKName)
            'Field name in related table.
            fld.ForeignName = rst!FTableChildName
            'Append the field.
            .Fields.Append fld
            .Fields.Refresh
            'Repeat for other fields if a multi-field relation.
        End With
        'Save the newly defined relation to the Relations collection.
        dbs.Relations.Append rel
        dbs.Relations.Refresh
        rst.MoveNext
    Loop
    rst.Close
    'Clean up
    Set fld = Nothing
    Set rel = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Sub

Answer 2

You create a relation rel before you start the loop instead of inside the loop.

Sub DoARelation()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim rel As DAO.Relation
    Dim fld As DAO.Field
    Dim i As Long
    On Error Resume Next
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("TblAlterRelation", dbOpenForwardOnly)
    Do While Not rst.EOF
        'Create a new relation.
        Set rel = dbs.CreateRelation
        'Define its properties.
        With rel
            'Specify the primary table.
            .Table = rst!MainTableName
            'Specify the related table.
            .ForeignTable = rst!FTableName
            'Specify attributes for cascading updates and deletes.
            .Attributes = dbRelationUpdateCascade + dbRelationDeleteCascade
            'Add the fields to the relation.
            'Field name in primary table.
            Set fld = .CreateField(rst!MainTablePKName)
            'Field name in related table.
            fld.ForeignName = rst!FTableChildName
            'Append the field.
            .Fields.Append fld
            .Fields.Refresh
            'Repeat for other fields if a multi-field relation.
        End With
        'Save the newly defined relation to the Relations collection.
        dbs.Relations.Append rel
        dbs.Relations.Refresh
        rst.MoveNext
    Loop
    rst.Close
    'Clean up
    Set fld = Nothing
    Set rel = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Sub

Answer 3

1. You can add an error handler to get out if an error occurs because the relationship has already been created.
2. Don't know, sorry.

Answer 4

Try the following:

1. Below the last line

.Fields.Append fld

insert

.Fields.Refresh

2. Below the line

db.Relations.Append rel

insert

db.Relations.Refresh

Answer 5

Sorry, I now copied your advised code below one and paste it to a new module, run via immediate windows no result no relationship got build. Then remove the on error resume next and below error 3125 appears

Sub DoARelation()

Dim dbs As DAO.Database 

Dim rst As DAO.Recordset 

Dim rel As DAO.Relation 

Dim fld As DAO.Field 

Dim i As Long 

On Error Resume Next 

Set dbs = CurrentDb 

Set rst = dbs.OpenRecordset("TblAlterRelation", dbOpenForwardOnly) 

Do While Not rst.EOF 

    'Create a new relation. 

    Set rel = dbs.CreateRelation 

    'Define its properties. 

    With rel 

        'Specify the primary table. 

        .Table = rst!MainTableName 

        'Specify the related table. 

        .ForeignTable = rst!FTableName 

        'Specify attributes for cascading updates and deletes. 

        .Attributes = dbRelationUpdateCascade + dbRelationDeleteCascade 

        'Add the fields to the relation. 

        'Field name in primary table. 

        Set fld = .CreateField(rst!MainTablePKName) 

        'Field name in related table. 

        fld.ForeignName = rst!FTableChildName 

        'Append the field. 

        .Fields.Append fld 

        .Fields.Refresh 

        'Repeat for other fields if a multi-field relation. 

    End With 

    'Save the newly defined relation to the Relations collection. 

    dbs.Relations.Append rel 

    dbs.Relations.Refresh 

    rst.MoveNext 

Loop 

rst.Close 

'Clean up 

Set fld = Nothing 

Set rel = Nothing 

Set rst = Nothing 

Set dbs = Nothing 

End Sub

When clicked on debug, below line gets highlighted,

Kindly check and advise