[kapetang]

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

Σταύρο στην ΒΔ που ανέβασες έχω προσθέσει:

1) Τον πίνακα ApousiesPerMonth_p στον οποίο με κατάλληλο κώδικα καταγράφονται τα χρονικά διαστήματα των απουσιών, αλλά έτσι ώστε η αρχή και το τέλος τους να ανήκει στον ίδιο μήνα.

Αντιμετωπίζονται χρονικά διαστήματα πολλών μηνών, αλλά και ετών

Έτσι, όταν θέλεις αποτελέσματα ανά μήνα, αντί να χρησιμοποιείς στα ερωτήματα και στις εκθέσεις τον πίνακα apousies_p θα πρέπει να χρησιμοποιείς τον ApousiesPerMonth_p.

2) Τη φόρμα frmDiastimataAnaMina στην οποία πατώντας το σχετικό κουμπί εκτελείται ο κώδικας ο οποίος δημιουργεί τις κατάλληλες εγγραφές στον πίνακα ApousiesPerMonth_p.

3) Τη λειτουργική μονάδα TomiDiastimaton που περιέχει τον κώδικα που φαίνεται παρακάτω.

Option Compare Database
Option Explicit


Public Sub XronikoDiastimaAnaMina(Optional StartDate As Date = #12:00:00 AM#, _
                                    Optional EndDate As Date = #12/31/9998#)

'Χωρίζει ένα χρονικό διάστημα σε τμήματα έτσι ώστε κάθε τμήμα να ανήκει στον ίδιο μήνα.
'Τα διαστήματα [StartDate, EndDate] τα παίρνει από τον πίνακα apousies_p
'και τα αποτελέσματα τα αποθηκεύει στον πίνακα ApousiesPerMonth_p
'====================================================================================


    Dim StartMonth As Date, EndMonth As Date    'ημερομηνίες έναρξης και λήξης του μήνα
    Dim numMonths As Integer, j As Integer      'το πλήθος μηνών του χρονικού διαστήματος
    Dim rs As DAO.Recordset
    Dim strSQL As String
    Dim yr As Integer, mn As Integer
    Dim Tomi As Variant  'Αποθηκεύει την αρχή και το τέλος της τομής ενός μήνα με το διάστημα

    On Error GoTo Err_Hadler
    ' Εγκυρότητα παραμέτρων
    If StartDate > EndDate Then Exit Sub

    'Προσαρμογή άκρων χρονικού διαστήματος για σύμπτωση με την αρχή και το τέλος μήνα
    StartDate = DateSerial(Year(StartDate), Month(StartDate), 1)
    EndDate = DateSerial(Year(EndDate), Month(EndDate) + 1, 0)


    'Διαγραφή των εγγραφών του πίνακα ApousiesPerMonth_p, δημιουργία recordset
    CurrentDb.Execute ("DELETE * FROM ApousiesPerMonth_p")
    strSQL = "SELECT ID_apousies_p, kod_apousies_p, idosapousias_apousies_p, " _
              & "apo_apousies_p, eos_apousies_p FROM apousies_p WHERE " _
              & "apo_apousies_p>=#" & Format(StartDate, "m/d/yyyy") _
              & "# AND eos_apousies_p<= #" & EndDate & "#"
    Set rs = CurrentDb.OpenRecordset(strSQL)

    'Γέμισμα πίνακα ApousiesPerMonth_p
    With rs
        If Not (rs.EOF And rs.BOF) Then
            .MoveFirst
            Do Until .EOF
                numMonths = DateDiff("m", !apo_apousies_p, !eos_apousies_p) + 1
                yr = Year(!apo_apousies_p): mn = Month(!apo_apousies_p)
                For j = 0 To numMonths - 1
                    StartMonth = DateSerial(yr, mn + j, 1)
                    EndMonth = DateSerial(yr, mn + j + 1, 0)
                    Tomi = TomiDiastimatonArray(!apo_apousies_p, !eos_apousies_p, StartMonth, EndMonth)
                    strSQL = "INSERT INTO ApousiesPerMonth_p (ID, kod_apousies_p, " _
                        & "idosapousias_apousies_p, Apo, Eos) values(" & !ID_apousies_p _
                           & ", '" & !kod_apousies_p & "', '" & !idosapousias_apousies_p & "' , #" _
                           & Format(Tomi(1), "m/d/yyyy") & "#, #" & Format(Tomi(2), "m/d/yyyy") & "#)"
                    CurrentDb.Execute strSQL
                Next
                .MoveNext
            Loop
        End If
    End With
Err_Hadler:
    If Err <> 0 Then
        MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    End If
    On Error Resume Next
    rs.Close: Set rs = Nothing
End Sub


Public Function TomiDiastimatonArray(Start1 As Variant, End1 As Variant, _
                                     Start2 As Variant, End2 As Variant) As Variant()

'Βρίσκει την τομή των διαστημάτων [Start1, End1] και [Start2, End2]
'Επιστρέφειτην αρχή tStart και το τέλος του διαστήματος της τομής [tStart, tEnd]
'==================================================================================
    Dim Tomi(1 To 2) As Variant

    'Αν δεν οριστούν τα διαστήματα
    If IsNull(Start1) Or IsNull(End1) Or IsNull(Start2) Or IsNull(End2) Then
        Tomi(1) = Null: Tomi(2) = Null
        TomiDiastimatonArray = Tomi
        Exit Function
    End If

    'Αν τα όρια των διαστημάτων δεν είναι σωστά επιστρέφει "Λάθος!"
    If Start1 > End1 Or Start2 > End2 Then
        Tomi(1) = "Λάθος!": Tomi(2) = "Λάθος!"
        TomiDiastimatonArray = Tomi
        Exit Function
    End If

    'Αν δεν υπάρχει τομή τα διαστήματα χαρακτηρίζονται ως "Ξένα!"
    If Start2 > End1 Or End2 < Start1 Then
        Tomi(1) = "Ξένα!": Tomi(2) = "Ξένα!"
        'Αν υπάρχει τομή υπολογίζονται τα άκρα της [tStart, tEnd]
    Else
        Tomi(1) = IIf(Start1 < Start2, Start2, Start1)
        Tomi(2) = IIf(End1 < End2, End1, End2)
    End If
    TomiDiastimatonArray = Tomi
End Function

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

ΥΓ Τι έγινε με το ερώτημα αντιγραφής και επικόλλησης ιδιοτήτων φόρμας. Νομίζω ότι χρωστάς στο φόρουμ μια απάντηση.