Πρόβλημα με συνδεδεμένη ΒΔ

[lefterisg]

Γεια σας. Είμαι νέο μέλος και ζητάω βοήθεια πρώτη φορά.
Έχω μία συνδεδεμένη ΒΔ στην οποία πρέπει να τσεκάρω με VBA την ενεργοποίηση ακεραιότητας αναφορών, αλλά και την διαδοχική ενημέρωση και την διαδοχική διαγραφή.
Ο παρακάτω κώδικας το κάνει αυτό, αλλά μόνο όταν είναι στην ίδια ΒΔ με τους πίνακες.

Option Compare Database
Option Explicit

Public Const dbRelationCascadeNull As Long = &H2000 'DAO bit for the Attributes of the Relation.


'DDL example
Function MakeRelJetADO1()
'Purpose: Create a Cascade-to-Null relation using DDL.
Dim strSql As String
strSql = "ALTER TABLE tblProduct ADD CONSTRAINT tblCategorytblProduct " & _
"FOREIGN KEY (CategoryID) REFERENCES " & _
"tblCategory (CategoryID) ON update cascade on DELETE cascade"
CurrentProject.Connection.Execute strSql
Debug.Print "Constraint created"
End Function

Function RelationExists(strRelName As String) As Boolean
'Purpose: Return True if the relation already exists.
On Error Resume Next
Debug.Print CurrentDb.Relations(strRelName).Attributes
RelationExists = (Err.Number = 0&)
End Function

Δεν το κάνει όταν τον εκτελώ από φόρμα συνδεδεμένης βάσης.
Παρακαλώ αν είναι δυνατόν για τη βοήθεά σας.
Σας ευχαριστώ, Λευτέρης.
Συνημμένα ανέβασα τις 2 ΒΔ

[kapetang]

Καλημέρα

Λευτέρη καλωσόρισες στην παρέα του φόρουμ.

Δοκίμασε τον παρακάτω κώδικα.

Function MakeRelJetADO()
'Purpose:   Create a Cascade-to-Null relation using DDL.
    On Error GoTo Err_Trap
    Dim strSql As String
    Dim cnn As New adodb.Connection
    Dim Mycnn As String
    
    
   'Να αντικατασταθεί με το πλήρες πραγματικό όνομα της εξωτερικής βάσης
    Mycnn = CurrentProject.Path & "\" & "CascadeToNull_παρ.mdb"

    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open Mycnn
    End With

    strSql = "ALTER TABLE tblProduct ADD CONSTRAINT tblCategorytblProduct " & _
             "FOREIGN KEY (CategoryID) REFERENCES " & _
             "tblCategory (CategoryID) ON update cascade on DELETE cascade"
    cnn.Execute strSql
Err_Trap:
    If Err.Number <> 0 Then
        If Err.Number = -2147217900 Then
            MsgBox "Υπάρχει ένας περιορισμός ακεραιότητας με όνομα tblCategorytblProduct "
        Else
            MsgBox "Error: " & Err.Number & vbCrLf & _
                    Err.Description
        End If
    Else
        MsgBox "Constraint created"
    End If
    On Error Resume Next
    cnn.Close: Set cnn = Nothing
End Function

Function RelationExists(strRelName As String) As Boolean
    'Purpose:   Return True if the relation already exists.
    Dim db As Database
    Dim strFullNameDB As String
    strFullNameDB = CurrentProject.Path & "\" & "CascadeToNull_παρ.mdb"
    Set db = Workspaces(0).OpenDatabase(strFullNameDB)
    On Error Resume Next
    Debug.Print CurrentDb.Relations(strRelName).Attributes
    RelationExists = (Err.Number = 0&)
    db.Close: Set db = Nothing
End Function

Ο κώδικας, όπως είναι, θα λειτουργήσει αν και οι δύο βάσεις είναι στον ίδιο φάκελο.

Αν είναι σε διαφορετικό θα πρέπει να αλλάξεις στον κώδικα το πλήρες όνομα της εξωτερικής βάσης.

Φιλικά/Γιώργος

[Tasos]

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

Λευτέρη καλωσόρισες στο φόρουμ!

Ο κώδικας που παρουσιάζεις μπορεί να λειτουργήσει μόνο σε τοπικούς πίνακες μιας βάσης που είναι ανοιχτή και μόνο όταν αυτοί δεν χρησιμοποιούνται από κάποιο άλλο πρόγραμμα (συμπεριλαμβανομένης και της ίδιας της βάσης που περιέχει τον κώδικα).

Αν πρέπει η διαδικασία τροποποίησης να γίνει προγραμματιστικά τότε θα πρέπει:

• Να κλείσεις τυχόν ανοιχτές φόρμες, πίνακες ή ερωτήματα των οποίων τα δεδομένα πηγάζουν από πίνακες της βάσης παρασκηνίου.
• Να σιγουρευτείς ότι η βάση παρασκηνίου δεν χρησιμοποιείται από άλλο χρήστη.
• Να ανοίξεις τη βάση προγραμματιστικά . Εδώ θα πρέπει να δημιουργηθεί νέα συνεδρία της εφαρμογής προκειμένου να ανοίξει η βάση παρασκηνίου.
• Αφού έχουν γίνει τα παραπάνω τότε με κάποιες μικρές μετατροπές στον κώδικα σου θα μπορέσεις να αλλάξεις τις σχέσεις πινάκων της απομακρυσμένης βάσης.

Αν χρειαστείς βοήθεια στην εφαρμογή των παραπάνω γράψε στο φόρουμ.


Φιλικά




Τάσος

[lefterisg]

Γιώργο και Τάσο σας ευχαριστώ πάρα πολύ για την πολύτιμη βοήθειά σας.

Γιώργο, αντικατέστησα το όνομα της εξωτερικής βάσης όπως μου είπες και δούλεψε τέλεια.
Πραγματικά, χίλια ευχαριστώ, γιατί παιδεύτηκα πολύ χωρίς επιτυχία, πριν σας ζητήσω βοήθεια.
Τώρα θα προσπαθήσω την παρακάτω διαδρομή να τη βρίσκει αυτόματα, όπου και αν μετακινώ τον φάκελο.
Mycnn = "c:\cascade\CascadeToNull_παρ.mdb"
Αν αντιμετωπίσω πρόβλημα, θα ζητήσω και πάλι βοήθεια.
Και πάλι πολύ μεγάλο ευχαριστώ, Λευτέρης.

[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

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

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

Φιλικά

Τάσος

[lefterisg]

Τάσο, καλημέρα.
Σ' ευχαριστώ πάρα πολύ που ασχολείσε με το πρόβλημά μου.
Έβαλα τον κώδικα σε ενα κουμπί και φόρμα είναι κενή, σύμφωνα με τις οδηγίες σου.
Όταν εκτελεί την εντολή, μου βγάζει το μήνυμα :
Can not Find the Sourse Database!
Και τις δύο ΒΔ τις έχω στον ίδιο φάκελο.
Έχω Win 7 & office 2003.
Σε παρακαλώ, όταν μπορέσεις, δες τις ΒΔ που ανέβασα με το κώδικά σου.
Σε ευχαριστώ και πάλι,
Λευτέρης.

[Tasos]

Καλημέρα Λευτέρη!

Ο κώδικας παίρνει την πληροφορία για τη διαδρομή της βάσης παρασκηνίου από τον πίνακα
"MSysObjects" (στο παράδειγμα σου: C:\Users\Lefteris\Desktop\CascadeToNull_παρ.mdb)

Κατόπιν κάνει έλεγχο αν η βάση παρασκηνίου υπάρχει στη διαδρομή αυτή.
Αν δεν βρεθεί το αρχείο (όπως γίνεται στην περίπτωση σου) τότε η εκτέλεση του κώδικα
διακόπτεται και ο χρήστης παίρνει το μήνυμα. "Can not Find the Sourse Database!"

Αυτό σημαίνει ότι οι αναφορές των πινάκων της FrondEnd.mdb του παραδείγματος σου (C:\Users\Lefteris\Desktop\CascadeToNull_παρ.mdb) δεν είναι οι σωστές.

Μπορείς να το διαπιστώσεις και χειροκίνητα αν προσπαθήσεις να ανοίξεις ένα από τους συνδεδεμένους πίνακες στην FrondEnd.mdb.

Θα πρέπει με τη βοήθεια του οδηγού διαχείρισης πινάκων να επανασυνδέσεις τους πίνακες με το κατάλληλο αρχείο (στο παράδειγμα σου το BackEnd.mdb).


ΥΓ. Δες το μήνυμα: http://www.ms-office.gr/forum/access...in-access.html


Δοκίμασε το παραπάνω και τα λέμε.

Φιλικά

Τάσος

[lefterisg]

Τάσο και πάλι καλημέρα.
Είχες δίκιο σχετικά με την επανασύνδεση πινάκων.
Προσάρμοσα τον κώδικα στην κανονική μου ΒΔ η οποία κάνει αυτόματα επανασύνδεση πινάκων και δούλεψε τέλεια.
Να είσαι πάντα καλά, σε ευχαριστώ πάρα πάρα πολύ.
Λευτέρης.