[kapetang]

Καλημέρα στην παρέα

Στο πρόβλημα της εμφάνισης σε μία έκθεση στοιχείων από δύο πίνακες που δεν ενώνονται, το οποίο έθεσε ο Δημήτρης (Dimmag), δόθηκε από το φίλο μου Νίκο (Meteora) μια απλή και χωρίς κώδικα λύση.
Δουλεύοντας για κάποια λύση με κώδικα σκέφτηκα δύο τρόπους:
1) Στο συμβάν με το άνοιγμα της έκθεσης (Open) να δημιουργείται ένας νέος πίνακας (Test) που θα συγκεντρώνει τα στοιχεία των δύο πινάκων (tablaA, tableB) και θα αποτελεί την προέλευση εγγραφών της έκθεσης.
Τη λύση αυτή την υλοποίησα στην έκθεση «rptTableA_TableB», στη ΒΔ που επισυνάπτω.
2) Στο συμβάν με το άνοιγμα της έκθεσης (Open) να τίθεται η προέλευση εγγραφών της έκθεσης στον πίνακα που έχει τις περισσότερες εγγραφές (πχ TableA) και η προέλευση του στοιχείου ελέγχου που ανήκει στον άλλο πίνακα (πχ fieldB του πίνακα tableB) σε μία κατάλληλη συνάρτηση.
Η προσπάθεια αυτή, απέτυχε παταγωδώς και φαίνεται στην έκθεση «rptTableA_TableB2».
Ενώ όταν ο πίνακας «tableB» έχει περισσότερες εγγραφές από τον «tableΑ» δίνει σωστά αποτελέσματα όταν συμβαίνει το αντίθετο βγάζει μήνυμα λάθους.
Παρά τις προσπάθειες «κόλλησα» και δεν μπόρεσα να διορθώσω το λάθος.
Παραθέτω τον κώδικα, με κάποια σχόλια, και παρακαλώ τους φίλους του φόρουμ να τον μελετήσουν και να βοηθήσουν στη διόρθωση.

Option Compare Database
Option Explicit
Dim x As Long

Private Sub Report_Open(Cancel As Integer)
    On Error GoTo Error_Trap
    If DCount("*", "tableA") >= DCount("*", "tableB") Then
        Me!fieldB.ControlSource = "=SetB([fieldA])"
        Me.RecordSource = "tableA"
    Else
        Me!fieldA.ControlSource = "=SetA([fieldB])"
        Me.RecordSource = "tableB"
    End If
    Exit Sub
Error_Trap:
    MsgBox Err.Number & " " & Err.Description
End Sub

Public Function SetA(m As Variant)
    'Ο κώδικας λειτουργεί σωστά
    With CurrentDb.OpenRecordset("tableA")
        'Επειδή ο πίνακας tableA έχει λίγότερες εγγραφές από τον tableB
        'κάποια στιγμή ή .move x θα προκαλέσει λάθος
        On Error Resume Next
        .Move x
        If Err = 0 Then
            SetA = !fieldA
        Else
            SetA = ""
            Err.Clear
        End If
        On Error GoTo 0
        x = x + 1
    End With
End Function

Public Function SetB(m As Variant)
    'Δε λειτουργεί σωστά. Πρόσθεσα παγίδευση σφάλματος
    ' για να φανεί το είδος του σφάλματος
    On Error GoTo TrapError
    With CurrentDb.OpenRecordset("tableB")
        'On Error Resume Next
        .Move x
        If Err = 0 Then
            SetB = !fieldB
        Else
            SetB = ""
            Err.Clear
        End If
        'On Error GoTo 0
        x = x + 1
    End With
    Exit Function
TrapError:
    MsgBox Err.Number & " " & Err.Description
End Function

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