[Tasos]

Καλημέρα σε όλους!

Αγαπητέ Λευτέρη,
Έστω ότι η βάση παρασκηνίου ονομάζεται BackEnd και η βάση με τις φόρμες, ερωτήματα κλπ. FrondEnd.

Ο παρακάτω κώδικας μπορεί να αντιστοιχηθεί σε ένα κουμπί κάνει τα εξής:

• Παίρνει την πληροφορία για τη διαδρομή της βάσης παρασκηνίου από τον πίνακα "MSysObjects"
• Κλείνει τυχόν ανοιχτούς πίνακες ερωτήματα, φόρμες, εκθέσεις της FrondEnd αποδεσμεύοντας έτσι τους πίνακες της BackEnd.
• Ανοίγει την BackEnd για αποκλειστική χρήση αφού προηγουμένως πιστοποιηθεί ότι δεν
  υπάρχουν άλλοι συνδεδεμένοι χρήστες. Έτσι αποκλείουμε "ατυχήματα" που θα μπορούσαν
  να συμβούν κατά τη διαδικασία δημιουργίας/τροποποίησης μιας σχέσης.
• Διαγράφει κάθε φορά την σχέση πινάκων με το ίδιο όνομα και δημιουργεί νέα που θα μπορούσε να περιέχει διαφορετικούς περιορισμούς ακεραιότητας.
  Μπορεί δηλαδή να τροποποιήσει τη σχέση.

Φρόντισε η φόρμα που θα περιέχει το κουμπί να είναι κενή (χωρίς στοιχεία που δεσμεύονται σε κάποιο συνδεδεμένο πίνακα).

Option Compare Database
Option Explicit

Private Sub cmdUpdateRelation_Click()
    Dim AccObject As AccessObject
    Dim AccApp As New Access.Application
    Dim RemoteDB As dao.Database    ' Το αντικείμενο "CurrentDB" της BackEnd
    Dim RemoteDBFullName As String    'Η διαδρομή της BackEnd
    Dim tdf As TableDef
    Dim success As String
    On Error Resume Next
    RemoteDBFullName = DLookup("Database", "MSysObjects", "Database is Not Null")
    On Error GoTo 0

    If RemoteDBFullName <> vbNullString Then
        If Dir(RemoteDBFullName, vbDirectory) = vbNullString Then
            MsgBox "Can not Find the Sourse Database!"
            Exit Sub
        End If
    End If
    For Each AccObject In CurrentData.AllTables
        If AccObject.IsLoaded Then
            DoCmd.Close acTable, AccObject.Name, acSaveYes
        End If
    Next
    For Each AccObject In CurrentData.AllQueries
        If AccObject.IsLoaded Then
            DoCmd.Close acQuery, CurrentData.Name, acSaveYes
        End If
    Next
    For Each AccObject In CurrentProject.AllForms
        If AccObject.IsLoaded And AccObject.Name <> Me.Name Then
            DoCmd.Close acForm, AccObject.Name, acSaveYes
        End If
    Next
    For Each AccObject In CurrentProject.AllReports
        If AccObject.IsLoaded Then
            DoCmd.Close acReport, AccObject.Name, acSaveYes
        End If
    Next
    On Error Resume Next
    AccApp.OpenCurrentDatabase filepath:=RemoteDBFullName, Exclusive:=True, bstrPassword:=vbNullString
  
    If Err <> 0 Then
        MsgBox "Can not open the remote Database in exclusive mode! The procedure will not continue.", vbExclamation
        AccApp.Quit
        Set AccApp = Nothing
        Exit Sub
    End If  

    Set RemoteDB = AccApp.CurrentDb
'------------------------------------------------------------------------------------------------------------
'Microsoft Help
'------------------------------------------------------------------------------------------------------------
'dbRelationDeleteCascade     4096       Deletions cascade
'dbRelationDontEnforce       2          Relationship not enforced (no referential integrity)
'dbRelationInherited         4          Relationship exists in the database containing the two linked tables
'dbRelationLeft              16777216   Microsoft Access only.
'                                       In Design view, display a LEFT JOIN as the default join type.
'dbRelationRight             33554432   Microsoft Access only.
'                                       In Design view, display a RIGHT JOIN as the default join type.
'dbRelationUnique            1          One-to-one relationship
'dbRelationUpdateCascade     256        Updates cascade

'------------------------------------------------------------------------------------------------------------
' Επεξηγήσεις
'------------------------------------------------------------------------------------------------------------
 '            1. db:=RemoteDB 
'            2. RelName:="tblCategorytblProduct" Το όνομα της σχέσης
'            3. tdfName:="tblCategory" Το όνομα του Πίνακα
'            4. tdfFieldName:="CategoryID" Το όνομα του πεδίου σύνδεσης του Πίνακα
'            5. ReltdfName:="tblProduct" Το όνομα του σχετιζόμενου Πίνακα
'            6. ReltdfFieldName:="CategoryID" Το όνομα του πεδίου σύνδεσης του σχετιζόμενου Πίνακα
'            7. Attrs:=dbRelationDeleteCascade + dbRelationUpdateCascade)
'               Μπορεί να χρησιμοποιηθεί μόνο το ένα από τα δύο ή κάποιος συνδυασμός
'               σταθερών (αναγράφονται παραπάνω).

    success = CreateRelationship( _
            db:=RemoteDB, _
            RelName:="tblCategorytblProduct", _
            tdfName:="tblCategory", _
            tdfFieldName:="CategoryID", _
            ReltdfName:="tblProduct", _
            ReltdfFieldName:="CategoryID", _
            Attrs:=dbRelationDeleteCascade + dbRelationUpdateCascade)    'Μπορεί να προσαρμοστεί
    If success = 1 Then
        MsgBox "Relation ship created successfully!"
    Else
        MsgBox success, vbExclamation
    End If
    AccApp.CloseCurrentDatabase
    Set RemoteDB = Nothing
    AccApp.Quit
    Set AccApp = Nothing
End Sub

Private Function CreateRelationship( _
        db As dao.Database, _
        RelName As String, _
        tdfName As String, _
        tdfFieldName As String, _
        ReltdfName As String, _
        ReltdfFieldName As String, _
        Attrs As Long) As String

    Dim rels As dao.Relations
    Dim rel As dao.Relation
    Set rels = db.Relations
    On Error GoTo ErrH
    For Each rel In rels
        If rel.Name = RelName Then
            rels.Delete RelName
            Exit For
        End If
    Next
    Set rel = db.CreateRelation( _
            Name:=RelName, _
            Table:=tdfName, _
            ForeignTable:=ReltdfName, _
            Attributes:=Attrs)

    rel.Fields.Append rel.CreateField(tdfFieldName)
    rel.Fields(tdfFieldName).ForeignName = ReltdfFieldName
    rels.Append rel
ErrH:
    Set rels = Nothing
    Set db = Nothing
    If Err <> 0 Then
        CreateRelationship = Err.Description
    Else
        CreateRelationship = 1
    End If
End Function

Είναι λίγο "μακρύς" αλλά περιέχει τις απαραίτητες διαδικασίες προκειμένου να γίνει το ζητούμενο με περισσότερη ασφάλεια.

Καλή συνέχεια!

Φιλικά

Τάσος