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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
Public Function StCreatRelation(BaseName As String, TablePrinc As String, TableSec As String, Champs As String, ChampsSec As String, Unique As Boolean, CascadeUpdate As Boolean, CascadeDelete As Boolean)
'création d'une relation d'integerité référentielle
'BaseName = nom de la base
'TablePrinc = nom de la table principale
'TableSec = nom de la table secondaire
'Champ = Nom du champs sur le quel porte la relation
' (Nb: avec cette routine le chanmp doit exister dans les deux table avec le même nom)
'Unique Si true => Relation 1 à 1
' Si False => Relation 1 à plusieurs
'CascadeUpdate Si true => mise à jour du contenu du chanmp dans la table secondaire
'CascadeDelete Si true => supression en cascade de tous les enregistrements connexes dans la table secondaire
Dim Dbse As dao.Database
Dim Rel As dao.Relation
Dim Fld As dao.Field
Dim Attr As Long
Dim iPosit1 As Integer
Dim iPosit2 As Integer
Dim iTest As Integer
Dim RelationName As String
Set Dbse = dao.OpenDatabase(BaseName, False, False, GetPassWord(BaseName))
Attr = 0
If Unique Then
Attr = Attr + dbRelationUnique
End If
If CascadeUpdate Then
Attr = Attr + dbRelationUpdateCascade
End If
If CascadeDelete Then
Attr = Attr + dbRelationDeleteCascade
End If
On Error GoTo Suivre
Encore:
RelationName = Left$("z" & Trim(TablePrinc) & "~" & Trim(TableSec) & "~" & Champs, 64)
Set Rel = Dbse.Relations(RelationName)
' si on est ici c'est que la relation existe déjà
' si non on est en erreur et on passe dans suite
Set Rel = Nothing
Dbse.Close
StCreatRelation = 0
DoEvents
Exit Function
Suivre:
Resume Suite
Suite:
Set Rel = Dbse.CreateRelation(RelationName, TablePrinc, TableSec, Attr)
Rel.Attributes = Attr
iPosit1 = InStr(Champs, ",")
While iPosit1 > 0
Set Fld = Rel.CreateField(Left$(Champs, iPosit1 - 1))
Champs = Mid$(Champs, iPosit1 + 1)
iPosit2 = InStr(ChampsSec, ",")
Fld.ForeignName = Left$(ChampsSec, iPosit2 - 1)
ChampsSec = Mid$(ChampsSec, iPosit2 + 1)
iPosit1 = InStr(Champs, ",")
Rel.Fields.Append Fld
Wend
Set Fld = Rel.CreateField(Champs)
Fld.ForeignName = ChampsSec
Rel.Fields.Append Fld
On Error GoTo ErrCreatRel
Dbse.Relations.Append Rel
On Error GoTo 0
StCreatRelation = 0
Sortie:
Dbse.Close
DoEvents
Exit Function
ErrCreatRel:
StCreatRelation = -1
MsgBox "Erreur n° " & Str$(Err) & vbCrLf & _
Err.Description & vbCrLf & _
vbCrLf & _
"Relation entre " & TablePrinc & " et " & TableSec & vbCrLf & _
Champs & vbCrLf & _
ChampsSec, vbCritical
Resume Sortie
End Function |
