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

Dear Mr. Hans,

Thank you for your reply and advise.

As advised, I will be applying the error handler, for the time being I try with On error resume next.

To do the same for several table,I tried to refer to the table, the same way your advise for the Alter column in one of the today's thread. All code going ok, it created the relationship but only for the first record.

I am making some mistake in the loop code. Kindly review my code and advise the correction, so that I can be able to make the relationship for the all the 15 tables .

The code is as below (no error - but does the job for only one - first record)

Sub DoARelation()

Dim dbs As DAO.Database

Dim rst As DAO.Recordset 

Dim rel As DAO.Relation

Dim fld As DAO.Field

Set dbs = CurrentDb() 

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

'Create a new relation.

Set rel = dbs.CreateRelation("MyMainTableMyRelatedTable")

Do While Not rst.EOF

On Error Resume Next

'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 

Set rst = Nothing 

Set dbs = Nothing 

'Clean up

Set fld = Nothing

Set rel = Nothing

Set dbs = Nothing

End Sub

The table image same like earlier, which I am referring to the above code is: