|
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
|