[AC-2003] Créations des Relations par VBA

Bonjour,

Je voudrais créer les relations par code, et je me trouve confronté à un problème.

Lorsque j’utilise ce code pour la création d’une seule relation celle-ci se créer bien dans la tbl system « MSysRelationships », et elle est bien visible sur le schéma relationnel.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Private Sub Commande1_Click()
Dim oDb As DAO.Database
Dim oRlt As DAO.Relation
Dim oFld As DAO.Field
Set oDb = CurrentDb
 
'Crée la relation
Set oRlt = oDb.CreateRelation("Rlt_AdhérentsPostes", "tbl Adhérents", _
  "tbl Postes", dbRelationUpdateCascade)
‘Crée le champ
Set oFld = oRlt.CreateField("RéfAdhérent")
'Définit le nom de la clé externe
oFld.ForeignName = "RéfAdhérent"
'Ajoute le champ
oRlt.Fields.Append oFld
'Ajoute la relation
oDb.Relations.Append oRlt
'Rafraîhit la collection Relations
oDb.Relations.Refresh
'Ferme la base de données
oDb.Close
Set oDb = Nothing
End Sub

Par contre lorsque j’utilise ce code pour créer toutes les relations elles se créent bien
dans la tbl system « MSysRelationships », mais pas sur le schéma relationnel.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Private Sub createRelations()
    Dim db As Database
    Dim rel As Relation
    Dim myField As DAO.Field
    Dim sqlString As String
    Dim rs As DAO.Recordset
    Dim cpt As Integer
    cpt = 0
 
    Set db = Application.CurrentDb
    sqlString = "Select * from [tbl Relations]"
    Set rs = db.OpenRecordset(sqlString)
    If Not rs.EOF Then
        cpt = cpt + 1
        MsgBox cpt
        rs.MoveFirst
        While Not rs.EOF
            'Crée la relation
            Set rel = db.CreateRelation(rs.Fields("relationName"), rs.Fields("tableName"), rs.Fields("relForeignTable"), rs.Fields("relAttributes"))
            'Crée le champ
            Set myField = rel.CreateField(rs.Fields("relField"))
            'Définit le nom de la clé externe
            myField.ForeignName = rs.Fields("relForeignField")
            'Ajoute le champ
            rel.Fields.Append myField
            'Ajoute le la relation
            CurrentDb.Relations.Append rel
            'Rafraichit la collection Relations
            CurrentDb.Relations.Refresh
        rs.MoveNext
        Wend
    End If
End Sub

Pour quelles raisons les relations ne se font pas ?

Merci pour votre aide.

Salutations