Calendar - Allow multiple

[coolcatkelso]

Hiya

I found the Calendar2000 Dbase and was wondering if there is a way to allow for multiple entrys on the same day, Looking for at least 3.


The calendar has the time schedule on it and it works by time slots, so if I :start a job @ 7:30 till 8:30 it won't allow me to enter a new job for the same time, however, I need this option as we have 3 Vans and we each do different jobs?

Anyone help

Heres the code

Option Compare Database
Option Explicit
Public intPubMonth, intPubMyYear  'The big calendar's current month & year
Public Sub DayDoubleClicked(intDayClicked As Integer)
    Dim dteMyDate As Date
    dteMyDate = DateSerial(intPubMyYear, intPubMonth, intDayClicked)
    
'   Open the daily calendar to the date just double-clicked
    DoCmd.OpenForm "frmCalendar_Daily", , , , , , dteMyDate
    DoCmd.Close acForm, "frmCalendar_Large"
End Sub
 
Private Sub Form_Current()
    Call DisplayMeetings
 
End Sub
 
Private Sub Form_Open(Cancel As Integer)
    
    If IsNull(Me.OpenArgs) Then
        intPubMyYear = Year(Date)
        intPubMonth = Month(Date)
    Else
        intPubMyYear = Year(Me.OpenArgs)
        intPubMonth = Month(Me.OpenArgs)
    End If
    Call SetDates
    Call DisplayMeetings
End Sub
 
Private Sub Next_Click()
'   Display the next month
    intPubMonth = intPubMonth + 1
    
    If intPubMonth = 13 Then
        intPubMonth = 1
        intPubMyYear = intPubMyYear + 1
    End If
    
    Call SetDates
    Call DisplayMeetings
    
End Sub
Private Sub Previous_Click()
    
'   Display the previous month
    intPubMonth = intPubMonth - 1
    
    If intPubMonth = 0 Then
        intPubMonth = 12
        intPubMyYear = intPubMyYear - 1
    End If
    
    Call SetDates
    Call DisplayMeetings
End Sub
Public Sub SetDates()
'   Set up the day numbers on the calendar form, based on the month to be displayed
    Dim strdate As Date
    Dim r As Integer
    Dim intFirstDay As Integer
    Dim intLastDay As Integer
    Dim intDay As Integer
    Dim strDay As String
    
'   Clear the text from the calendar boxes and make them white
    For r = 1 To 37
        Me("Box" & Trim$(r)) = ""   'Empty number box
        Me("Box" & Trim(r)).BackColor = "16777215"
        Me("Box" & Trim(r)).Visible = True
        Me("Day" & Trim$(r)) = ""   'Empty day box
        Me("Day" & Trim(r)).BackColor = "16777215"
'   Hide the rarely-used sixth row of calendar boxes
        If r > 35 Then
            Me("Box" & Trim(r)).Visible = False
            Me("Day" & Trim(r)).Visible = False
        End If
        
    Next r
    
'   Update the month name - thanks to CyberCow for this fix
    txtMonth.Caption = Format(DateSerial(intPubMyYear, intPubMonth, 1), "mmmm, yyyy")
    
'   Get first day of the month.
    intFirstDay = Weekday(DateSerial(intPubMyYear, intPubMonth, 1))
    
'   Day of the current box.
    intDay = 2 - intFirstDay
    
'   First day of this month, in date format
    strdate = DateSerial(intPubMyYear, intPubMonth, 1)
    
'   Last date of this month (January=31, June=30, etc.)
    intLastDay = DateSerial(Year(strdate), Month(strdate) + 1, Day(strdate)) _
    - DateSerial(Year(strdate), Month(strdate), Day(strdate))
    
'   Cycle through the boxes, making useable days white and unsed days grey.
    For r = 1 To 37
        strDay = "Box" & Trim(r)
'       If this box is before the first day,
'       or if this box is after the last day, make it grey.
        If intDay < 1 Or intDay > intLastDay Then
            Me(strDay).BackColor = "12632256"
            Me(strDay).Visible = False
            Me("Day" & Trim(r)).BackColor = "12632256"
            Me("Day" & Trim(r)).Enabled = False 'Don't let them click a grey box
        Else
'           If necessary, unhide boxes on the rarely-used 6th row
            If r > 35 Then
                Me(strDay).Visible = True
                Me(strDay).BackColor = "16777215"
                Me("Day" & Trim(r)).Visible = True
                Me("Day" & Trim(r)).BackColor = "16777215"
                Me("Day" & Trim(r)).Enabled = True 'Clickable day
            End If
'           Put the day number in the little box in the upper corner of the day
            Me(strDay) = intDay
'           If this box is TODAY's date, paint the number box PINK!
            If (intPubMonth = Month(Date)) Then
                If (intDay = Day(Date)) Then
                    Me("Box" & Trim(r)).BackColor = "8421631"
                End If
            End If
        End If
        intDay = intDay + 1
    Next r
End Sub
Public Sub DisplayMeetings()
    
'   Add any meetings that occur this month to the proper day box on the form
    
    Dim strSQL As String
    Dim intTemp As Integer
    Dim intDays(37) As Integer
    Dim strDays(31) As String
    Dim strApptSubject As String
    Dim strApptStartTime As String
    Dim strApptDate As String
    Dim r As Integer
    Dim rst
    
'   To start, clear all meetings from every day
    For r = 1 To 37
        Me("Day" & Trim$(r)) = ""
    Next r
'   Grab this month's meetings from the tblAppointments table
'   Sorted by TIME, but not by DATE for some reason
    strSQL = "SELECT tblAppointments.* " & _
             "FROM tblAppointments " & _
             "WHERE Month([ApptDate])= " & intPubMonth & " AND Year([ApptDate]) = " & intPubMyYear & _
             " ORDER BY ApptStartTime;"
    Set rst = CurrentDb.OpenRecordset(strSQL)
    
'   Skip adding appointments if there are none for this month
    If rst.RecordCount > 0 Then
    
'       Populate array intDays(r) with the day of the month (or zero if the box is unused)
        For r = 1 To 37
            If Me("Box" & Trim(r)) = "" Then
                intDays(r) = 0
            Else
                intDays(r) = Me("Box" & Trim(r))
            End If
            Me("Day" & Trim(r)) = ""
        Next r
    
        rst.MoveFirst
        
        Do While Not rst.EOF
'           Grab the time, date and subject of each appointment
            strApptStartTime = Format(rst!ApptStartTime, "hh:mm AMPM")
            strApptDate = rst!ApptDate
'           Truncate the appointment description
            strApptSubject = Left(rst!Appt, 20)
        
'           Get the day of the month for this appointment
            intTemp = Day(rst!ApptDate)
            
'           Add the appointment details to the proper day
            strDays(intTemp) = strDays(intTemp) & vbCrLf & strApptStartTime & " - " & strApptSubject
    
            rst.MoveNext
        Loop
    
'       Loop through every calendar box.  If there are any appointments stored
'       in array strDays(r), add them to the calendar box
        For r = 1 To 37
            If intDays(r) <> 0 Then
                intTemp = intDays(r)
                Me("Day" & Trim(r)) = strDays(intTemp)
            End If
        Next r
    End If
    
    rst.Close
End Sub

________
Weed