calendario de citas

Hola, tengo una base de datos Access. En ella tengo una tabla “tblcitas” con los campos idcita; data, motiu; idpacient; horaini; horafin; assisteix.

El campo motiu es un campo buscado en tabla relacionada “tbltractament”---tractament

El campo idpacient es un campo buscado en la tbl relacionada “Tblpacientes” –Nom y llinatge1

Con la tbl citas tengo una qry “qryclassdataentry” en donde están estos campos de la tblcitas.

Idcita; data; idpacient, motiu, horaini y horafin

Tengo un formulario “frmCalendar” donde hay una tabla con 6 filas y 7 columnas (días de la semana) , para que con dos cbos: cbomonth y cboyear automáticamente se pongan los números de los días en la tabla en la posición que toca.

Todo parece correcto. Al hacer clic en el día escogido, se abre otro formulario frmqryclassdataentry donde tengo los campos de la qryclassdata entry :

“idcita”, “data” ,“idpacient”,”motiu”, “horaini” y horafin”

Después de esta introducción explico el problema:

Al hacer clic en el día deseado del frmcalendar se abre el frmclassdataentry donde introduzco los valores de los campos “”data”, “idpaciente”, “motiu”, “horaini” y horafin”

Al cerrar este formulario esta información se tendría que volcar en el día que hemos clicado anteriormente, pero… No, no lo hace

En el evento frmclose () de frmclassdataentry tengo este código:

Private Sub Form_Close()

    Dim ctlName As String

    Dim i As Integer

    Dim dayOfMonth As Long

    For i = LBound(myArray) To UBound(myArray)

        ctlName = "txt" & CStr(i + 1)

        If Controls(ctlName).Tag = Me.ActiveControl.Tag Then

            dayOfMonth = myArray(Controls(ctlName).Tag, 0)     

            ' Actualizar los valores en la matriz myArray con los datos del frmClassDataEntry

            myArray(Controls(ctlName).Tag, 2) = Me.data

            ' También actualiza otros valores necesarios, como idpacient, motiu, horaini, horafin   

            ' Salir del bucle una vez que se actualiza el día correspondiente

            Exit For

        End If

    Next i

    ' Volver a imprimir la matriz actualizada en el formulario

    PrintAndUpdateArray

End Sub

 

El código Vba del frmCalendar es:

Option Explicit

Private intMonth As Integer

Private intYear As Integer

Private lngFirstDayOfMonth As Long

Private intFirstWeekday As Integer

Private intDaysInMonth As Integer

Private myArray() As Variant

 

Private Sub Form_Load()

With Me

    .cboMonth = Month(Date)

    .cboYear = Year(Date)

End With

Call Main

End Sub

 

Private Sub cboMonth_AfterUpdate()

On Error GoTo ErrorHandler

Call Main

ExitSub:

    Exit Sub

ErrorHandler:

    MsgBox "There has been an error. cbomonthafterupdate" & Err.Description

    Resume ExitSub

End Sub

 

Private Sub cboYear_AfterUpdate()

On Error GoTo ErrorHandler

Call Main

ExitSub:

    Exit Sub

ErrorHandler:

    MsgBox "There has been an error. cboyearafterupdate" & Err.Description

    Resume ExitSub

End Sub

 

Private Sub Main()

    On Error GoTo ErrorHandler

    Call InitVariables

    Do Until VariablesInitialized()

        DoEvents

    Loop

    Call InitArray

    Call LoadArray

    Call PrintArray

ExitSub:

        Exit Sub

ErrorHandler:

        MsgBox "There has been an error in Main: " & Err.Description

        Resume ExitSub

End Sub

 

Private Function VariablesInitialized() As Boolean

    ' Verificar si las variables necesarias se han inicializado correctamente

    If intMonth <> 0 And intYear <> 0 And lngFirstDayOfMonth <> 0 And intFirstWeekday <> 0 And intDaysInMonth <> 0 Then

        VariablesInitialized = True

    Else

        VariablesInitialized = False

    End If

End Function

 

Private Function DataLoaded() As Boolean

    ' Verificar si los datos necesarios están completamente cargados

    If intMonth <> 0 And intYear <> 0 And lngFirstDayOfMonth <> 0 And intFirstWeekday <> 0 And intDaysInMonth <> 0 Then

        DataLoaded = True

    Else

        DataLoaded = False

    End If

End Function

 

Private Sub InitVariables()

    On Error GoTo ErrorHandler

 If IsNull(Me.cboMonth) Or IsNull(Me.cboYear) Then

        MsgBox "Please select both month and year."

        Exit Sub

    End If

    intMonth = Me.cboMonth

    intYear = Me.cboYear

    lngFirstDayOfMonth = CLng(DateSerial(intYear, intMonth, 1))

    intFirstWeekday = getFirstWeekday(lngFirstDayOfMonth)

    intDaysInMonth = getDaysInMonth(intMonth, intYear)

Exit Sub

ErrorHandler:

    MsgBox "There has been an error in InitVariables: " & Err.Description

End Sub

 

Private Sub InitArray()

Dim i As Integer

ReDim myArray(0 To 41, 0 To 2)

For i = 0 To 41

myArray(i, 0) = lngFirstDayOfMonth - intFirstWeekday + 1 + i

    If Month(myArray(i, 0)) = intMonth Then

        myArray(i, 1) = True

        myArray(i, 2) = Day(myArray(i, 0))

    Else

        myArray(i, 1) = False

    End If

Next i

End Sub

Private Sub LoadArray()

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim rsFiltered As DAO.Recordset

Dim strSQL As String

Dim i As Integer

strSQL = "SELECT tblCitas.IdCita, tblCitas.idpacient, tblCitas.data, tblCitas.horaini, tblCitas.horafin, tblCitas.Hora, tblCitas.Motiu, tblCitas.asisteix, " _

    & "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & Replace(CStr([tblCitas].[horaini]),',','.')) AS Horaini, " _

    & "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & Replace(CStr([tblCitas].[horafin]),',','.')) AS Horafin " _

    & "FROM tbltractaments RIGHT JOIN tblCitas ON tbltractaments.Idtractament = tblCitas.[Motiu] " _

    & "ORDER BY tblcitas.[data];"

Set db = CurrentDb

Set rs = db.OpenRecordset(strSQL)

    If Not rs.BOF And Not rs.EOF Then

        For i = LBound(myArray) To UBound(myArray)    

       If myArray(i, 1) Then

                rs.Filter = "[data]=" & myArray(i, 0)         

       Set rsFiltered = rs.OpenRecordset

       Do While (Not rsFiltered.EOF)       

             myArray(i, 2) = myArray(i, 2) & vbNewLine _

                    & rsFiltered!StartTime & " - " _

                    & rsFiltered!EndTime & " " _

                    & rsFiltered!Code & " " _

                    & rsFiltered!Teacher

                rsFiltered.MoveNext

               Loop

             End If

        Next i

  End If

     rsFiltered.Close

    rs.Close

Set rsFiltered = Nothing

Set rs = Nothing

Set db = Nothing

End Sub

Private Sub PrintArray()

On Error GoTo ErrorHandler

Dim strCtlName As String

Dim i As Integer

For i = LBound(myArray) To UBound(myArray)

    strCtlName = "txt" & CStr(i + 1)

    Controls(strCtlName).Tag = i

    Controls(strCtlName) = ""

    Controls(strCtlName) = myArray(i, 2)

Next i

ExitSub:

    Exit Sub

ErrorHandler:

    MsgBox "There has been an error. printarray"

    Resume ExitSub

End Sub

 

Private Sub OpenContinuousForm(ctlName As String)

On Error GoTo ErrorHandler

Dim ctlValue As Integer

Dim dayOfMonth As Long

ActlValue = Controls(ctlName).Tag

dayOfMonth = myArray(ctlValue, 0)

Debug.Print "Day of Month: " & dayOfMonth ' Verifica si el día del mes se está pasando correctamente

DoCmd.OpenForm "frmClassDataEntry", , , "[data]=" & dayOfMonth, acFormEdit

ExitSub:

    Exit Sub

ErrorHandler:

    MsgBox "There has been an error. opencontinuosform"

    Resume ExitSub

End Sub

 

For i = LBound(myArray) To UBound(myArray)

    strCtlName = "txt" & CStr(i + 1)

    If Not IsNull(Me.Controls(strCtlName)) Then

        Controls(strCtlName).Tag = i

        Controls(strCtlName).Value = myArray(i, 0) ' Aquí, asegúrate de establecer el valor correcto del control

    End If

Next i

El código lo tengo así en InitArray

Private Sub InitArray()

Dim i As Integer

ReDim myArray(0 To 41, 0 To 2)

For i = 0 To 41

    myArray(i, 0) = lngFirstDayOfMonth - intFirstWeekday + 1 + i

    If Month(myArray(i, 0)) = intMonth Then

        myArray(i, 1) = True

        myArray(i, 2) = Day(myArray(i, 0))

    Else

        myArray(i, 1) = False

        End If

Next i

End Sub

 

El código de printArray es:

Private Sub PrintArray()

On Error GoTo ErrorHandler

Dim strCtlName As String

Dim i As Integer

For i = LBound(myArray) To UBound(myArray)

    strCtlName = "txt" & CStr(i + 1)

    If Not IsNull(Me.Controls(strCtlName)) Then

        Controls(strCtlName).Tag = i

        Controls(strCtlName) = ""

        Controls(strCtlName) = myArray(i, 2)

    End If

Next i

ExitSub:

    Exit Sub

ErrorHandler:

    MsgBox "There has been an error. printarray"

    Resume ExitSub

End Sub

Y para cada uno de los cuadros independientes de la tabla insertada en el formulario frmcalendar (6 filas x 7 columnas – una por cada día de la semana.) tengo este código:

Private Sub txt1_Click()

If Me.ActiveControl.Text <> "" Then

    OpenContinuousForm Me.ActiveControl.Name

End Sub

 

Private Sub txt2_Click()

If Me.ActiveControl.Text <> "" Then

    OpenContinuousForm Me.ActiveControl.Name

End If

End Sub

 

 

Private Sub txt3_Click()

If Me.ActiveControl.Text <> "" Then

    OpenContinuousForm Me.ActiveControl.Name

    End If

End Sub

 

Private Sub txt4_Click()

If Me.ActiveControl.Text <> "" Then

    OpenContinuousForm Me.ActiveControl.Name

End Sub

 

Y así hasta el resto de los 42 cuadros independientes

 

Creo que el problema está en los códigos de PRINT ARRAY (¿puede ser???)

Gracias por vuestra ayuda

Si habéis llegado a leer hasta aquí merecéis mil millones de gracias.

A ver si entre todos lo podemos solucionar