locked
A challenging question - about an appointment module RRS feed

  • Question

  • Good morning,
    This is a tough one, hopefully someone will be able to figure it out. I have a module that I download and customize to fit my needs and I have a problem that I can't figure.
    I have a form that is name [frmCalendarDaily], I can make appointment from 08:00 AM to 16:00 PM, however, if I stop the appointment at 16:15, I have an error like this:
    Execution error 9 (In the code, I did put underline the line that cause the error)
    On the debugging, here what's I see when I pass the mouse over the field:
    While debugging, these are the values on that code: intLength = 34 strApptEndTime = "18:15:00" and strApptStartTime = "16:15:00"
     
    Option Compare Database
    Option Explicit
    
    Private Sub cmdOpenCalendarLarge_Click()
    
    '   Open the daily calendar to the date just double-clicked
        DoCmd.OpenForm "frmCalendar_Large1", , , , , , dtePubMyDate
        DoCmd.Close acForm, "frmCalendar_Daily"
    
    End Sub
    
    
    Private Sub Form_Open(Cancel As Integer)
    
        If IsNull(Me.OpenArgs) Then
    '       Open the form to today's date if there are no arguments
            dtePubMyDate = Date
          Else
    '       Use the arguments to set the date
            dtePubMyDate = Me.OpenArgs
        End If
    
    '   Add any meetings scheduled for the currently-displayed day
        Call DisplayDailyMeetings
    
    End Sub
    
    '   This sub fills in the appointments on the daily calendar.
    
    Public Sub DisplayDailyMeetings()
        
    Dim strSQL As String
    Dim I As Integer
    Dim r As Integer
    Dim intTemp As Integer
    Dim intLength(30) As Integer
    Dim strHours(64) As String
    Dim strApptSubject As String
    Dim strApptStartTime As String
    Dim strApptEndTime As String
    Dim rst
            
    '   Clear all appointments and shading
        For r = 1 To 64
            Me("txtShade" & Trim(r)) = ""
            Me("txtShade" & Trim(r)).BackColor = 6974207
            Me("txt" & Trim(r)) = ""
            strHours(r) = ""
        Next r
    
    '   Update the active date in the form header
        Me.lblDate.Caption = Format(dtePubMyDate, "Short Date")
    
    '   Get the appointments for the active date
        strSQL = "SELECT tblAppointments1.*, tblHour.HourID " & _
                 "FROM tblAppointments1 INNER JOIN tblHour " & _
                 "ON tblAppointments1.ApptStartTime = tblHour.Hours " & _
                 "WHERE tblAppointments1.ApptDate = " & SQLDate(dtePubMyDate) & _
                 "ORDER BY ApptStartTime;"
                     
        Set rst = CurrentDb.OpenRecordset(strSQL)
    
        
    '   If there are appointments for the active date...
        If rst.RecordCount > 0 Then
        
    '       Loop through the active date's appointments and assign
    '       the subject/length of appointment to the right arrays
            rst.MoveFirst
            Do While Not rst.EOF
                strApptStartTime = rst!ApptStartTime
                strApptEndTime = rst!ApptEndTime
                strApptSubject = rst!Appt
                intTemp = rst!HourID
            
    '           assign the subject to the array
                If Not IsNull(strApptSubject) Then
                    strHours(intTemp) = strApptSubject
                    
    '               Calculate minutes, then divide by 15 to get half hour increments
                    intLength(intTemp) = Abs(DateDiff("n", strApptEndTime, strApptStartTime)) / 15
                End If
                rst.MoveNext
            Loop
        
    '       Loop through the textboxes and fill in the appointments and
    '       shade the times that the appointment takes up.  Also, add arrows.
            For r = 1 To 64
                
    '           Meeting subject
                Me("txt" & Trim(r)) = strHours(r)
                    
    '           If the time box is shaded or free, skip it
                If (Me("txt" & Trim(r)).Value) = "" And (Me("txtShade" & Trim(r)).Value) = "" Then
                    Me("txtShade" & Trim(r)).BackColor = 10156544
                  ElseIf (Me("txt" & Trim(r)).Value) = "" And (Me("txtShade" & Trim(r)).Value) <> "" Then
    '               Do nothing
                  Else
    '               Shade in the time slots and put in the arrow markers (Symbol font)
                    Me("txtShade" & Trim(r)).BackColor = 6974207
    '               Up Arrow (beginning of meeting)
                    Me("txtShade" & Trim(r)).Value = Chr(173)
                    
                    For I = 1 To (intLength(r) - 2)
                        Me("txtShade" & Trim(r + I)).BackColor = 16417791
    '                   Vertical line (Middle of long meeting)
                        Me("txtShade" & Trim(r + I)).Value = Chr(189)
                    Next I
                    
                    Me("txtShade" & Trim(r + intLength(r) - 1)).BackColor = 6974207
    '               Down Arrow (End of meeting)
                    Me("txtShade" & Trim(r + intLength(r) - 1)).Value = Chr(175)
                End If
            Next r
        End If
        
        rst.Close
    
    End Sub
    
    Private Sub cmdClose_Click()
    
    '   Close the form
        DoCmd.Close acForm, Me.FormName
    
    End Sub
    
    Private Sub cmdNext_Click()
        
    '   Go to the next day
        
        dtePubMyDate = dtePubMyDate + 1
        Call DisplayDailyMeetings
    
    End Sub
    
    Private Sub cmdPrevious_Click()
        
    '   Go to the previous day
        dtePubMyDate = dtePubMyDate - 1
        Call DisplayDailyMeetings
    
    End Sub
    
    Private Function TextboxClicked()
    
    '   If one of the appointment textboxes (named txt#) is clicked,
    '   this subroutine is called, which opens the appointment form and
    '   displays the clicked appointment, if there is one.  If there is
    '   NO appointment for the clicked time, the user is prompted to
    '   add a new appointment.
    
    Dim strMyHour As String
    Dim strMyTime As String
    Dim strMyDate As String
    Dim loc As Long
    
    
        ' Let's get the numeric row value of the selected item
        loc = Mid(Screen.ActiveControl.Name, 4)
        ' Now let's check if its part of an appointment range
        If Nz(Me("txtShade" & loc).Value, "") <> "" Then
            Do While Asc(Me("txtShade" & loc).Value) <> 173
                loc = loc - 1
            Loop
            Me("txt" & loc).SetFocus
          Else ' It's not part of a range, offer a new record . . .
            If MsgBox("Do you want to add a new appointment at " & Me("lbl" & loc).Caption & " ?", vbQuestion + vbYesNo, "Add New Appointment?") = vbYes Then
                strMyHour = Mid(Screen.ActiveControl.Name, 4)
                strMyDate = CStr(dtePubMyDate)
                strMyTime = Me("lbl" & strMyHour).Caption
                DoCmd.OpenForm "frmAppointments"
                DoCmd.SelectObject acForm, "frmAppointments", False
                Forms![frmAppointments]![txtDate].Value = dtePubMyDate
                Forms![frmAppointments]![cboStartTime].Value = Me("lbl" & loc).Caption
                DoCmd.Close acForm, "frmCalendar_Daily"
                Exit Function
              Else
                Me.txtFocus.SetFocus ' moves focus from the selected text box to refresh form (not data)
                Exit Function
            End If
        End If
        
        strMyHour = Mid(Screen.ActiveControl.Name, 4)
        strMyDate = CStr(dtePubMyDate)
        strMyTime = Me("lbl" & strMyHour).Caption
    
        DoCmd.OpenForm "frmAppointments", , , , , , strMyDate & "," & strMyHour & "," & strMyTime
        DoCmd.Close acForm, "frmCalendar_Daily"
    
    End Function
    
    Public Function SQLDate(varDate As Variant) As String
        'Purpose:    Return a delimited string in the date format used natively by JET SQL.
        'Argument:   A date/time value.
        'Note:       Returns just the date format if the argument has no time component,
        '                or a date/time format if it does.
        'Author:     Allen Browne. allen@allenbrowne.com, June 2006.
        If IsDate(varDate) Then
            If DateValue(varDate) = varDate Then
                SQLDate = Format$(varDate, "\#mm\/dd\/yyyy\# ")             ' I added a trailing space here
            Else
                SQLDate = Format$(varDate, "\#mm\/dd\/yyyy hh\:nn\:ss\# ")  ' I added a trailing space here
            End If
        End If
    End Function
    
    Private Sub TexteBoutonFermer_Click()
    
    '   Close the form
        DoCmd.Close acForm, Me.FormName
    
    End Sub
    Public Function IsLoaded(ByVal strFormName As String) As Integer
     ' Returns True if the specified form is open in Form view or Datasheet view.
        
        Const conObjStateClosed = 0
        Const conDesignView = 0
        
        If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
            If Forms(strFormName).CurrentView <> conDesignView Then
                IsLoaded = True
            End If
        End If
            
    End Function
    
    Private Sub PageDown_Click()
      SendKeys "{PGDN}"
    End Sub
    
    Private Sub PageUp_Click()
      SendKeys "{PGUP}"
    End Sub
    Thank you all

    Claude Larocque
    Sunday, January 8, 2012 10:23 AM

Answers

  • You have declared intLength as an array with upper bound 30:

    Dim intLength(30) As Integer
    

    I guess intTemp was 34 when the error occurred, not intLength. That would cause the "Subscript out of bounds" error: 34 is greater than the upper bound 30.


    Regards, Hans Vogelaar
    Sunday, January 8, 2012 10:35 AM

All replies

  • You have declared intLength as an array with upper bound 30:

    Dim intLength(30) As Integer
    

    I guess intTemp was 34 when the error occurred, not intLength. That would cause the "Subscript out of bounds" error: 34 is greater than the upper bound 30.


    Regards, Hans Vogelaar
    Sunday, January 8, 2012 10:35 AM
  • The only thing I can say is WOW, thanks Hans, I have 12 forms that was working perfectly up to 16:00 and by adding Dim intLength(64) As Integer everythings works like a charm, you can't imagine how important this is, I have a client with 10 franchises that want my software, but he wanted an appointment module... you save the deal! Thank you so much


    Claude Larocque
    Sunday, January 8, 2012 5:41 PM