Populate Two Dates from One Table in Same Calendar

[dannyflee]

Hello,

I've used the calendar from the post:


http://bytes.com/topic/access/answer...ccess-calendar

I've used the widescreen calendar from Post #327.

Now i want to populate the calendar with 2 dates from the same table in stead of 1.

It now populates the field "Date" (with some additional client-fields like adres, postal, etc).
The second date that should be populated is "Datum_Werkzamheden" with the same additional client-fields.

The currnt VBA code that populates the calendar is:

Private Sub PopulateCalendar()
On Error GoTo Err_PopulateCalendar
Dim strFirstOfMonth As String, bytFirstWeekdayOfMonth As Byte, bytBlockCounter As Byte
Dim bytBlockDayOfMonth As Byte, lngBlockDate As Long, ctlDayBlock As TextBox
Dim bytDaysInMonth As Byte, bytEventDayOfMonth As Byte, lngFirstOfMonth As Long
Dim lngLastOfMonth As Long, lngFirstOfNextMonth As Long, lngLastOfPreviousMonth As Long
Dim lngEventDate As Long, bytBlankBlocksBefore As Byte, bytBlankBlocksAfter As Byte
Dim astrCalendarBlocks(1 To 42) As String, db As DAO.Database, rstEvents As DAO.Recordset
Dim strEvent As String
Dim lngSystemDate As Long   'CFB added 1-25-08
Dim ctlSystemDateBlock As TextBox, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
Dim strSQL As String        'Added 4/16/2008
Dim lngFirstDateInRange As Long     'CFB added 2-18-10
Dim lngLastDateInRange As Long      '
Dim lngEachDateInRange As Long      '
Dim strStartTime As String          '
 
 
 
lngSystemDate = Date        'CFB added 1-25-08
intMonth = objCurrentDate.Month
intYear = objCurrentDate.Year
lstEvents.Visible = True
lblEventsOnDate.Visible = False
lstEvents2.Visible = True
lblMonth.Caption = MonthAndYear(intMonth, intYear)
'strFirstOfMonth = "1/" & Str(intMonth) & Str(intYear)
strFirstOfMonth = Str(intMonth) & "/1/" & Str(intYear)
 
 
'*************************************************************************
  'ADezii
  'NOTE: Will work in the UK (United Kingdom) and other European Nations
  'strFirstOfMonth = "1/" & Str(intMonth) & Str(intYear)
'*************************************************************************
 
bytFirstWeekdayOfMonth = WeekDay(strFirstOfMonth)
lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
lngLastOfMonth = lngFirstOfNextMonth - 1
lngLastOfPreviousMonth = lngFirstOfMonth - 1
bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
 
 
 
 
 
 
 
 
 
Set db = CurrentDb
 
 
 
 
strSQL = "SELECT sales1.naam_klant, sales1.woonplaats, sales1.date, tblVisitType.Type, " & _
         "tblVisitType.Code, sales1.time " & _
         "FROM tblVisitType INNER JOIN sales1 ON tblVisitType.TypeID = sales1.TypeID " & _
         "WHERE sales1.date Between #" & CDate(lngFirstOfMonth) & "# And #" & CDate(lngLastOfMonth) & "# " & _
         "ORDER BY  sales1.time, sales1.naam_klant, sales1.woonplaats;"
 
 
Set rstEvents = db.OpenRecordset(strSQL)     'Added 4/16/2008
 
 
 
'MsgBox IsDate(rstEvents![Date])
 
 
'With rstEvents
 ' If .BOF And .EOF Then         'NO Records
  '  MsgBox "rstEvents contains 0 Records"
'   Else
  '   .MoveLast: .MoveFirst       'for accurate Record Count
    '   MsgBox "rstEvents consists of " & .RecordCount & " Records"
      '   MsgBox "[Date] " & IIf(IsDate(![Date]), " IS ", " IS NOT ") & _
        '        "recognized by Access as a Valid Date Field"
'   End If
  '   .Close: Set rstEvents = Nothing
' End With
 
'  Exit Sub
 
 
 
Do While Not rstEvents.EOF
  'CFB added 2-18-10
  'lngFirstDateInRange = CDate(rstEvents![Date])
  lngFirstDateInRange = rstEvents![Date]      '<Substitute for [Start Date]>
  If lngFirstDateInRange < lngFirstOfMonth Then
    lngFirstDateInRange = lngFirstOfMonth
  End If
    'lngLastDateInRange = CDate(rstEvents![Date])
  lngLastDateInRange = rstEvents![Date]         '<Substitute for [End Date]>
  If lngLastDateInRange > lngLastOfMonth Then
    lngLastDateInRange = lngLastOfMonth
  End If
 
  For lngEachDateInRange = lngFirstDateInRange To lngLastDateInRange
    bytEventDayOfMonth = (lngEachDateInRange - lngLastOfPreviousMonth)
    bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
                                              '<Substitute for [Title]>
      If astrCalendarBlocks(bytBlockCounter) = "" Then
       ' astrCalendarBlocks(bytBlockCounter) = Format$(rstEvents![Time], "hh:nn AM/PM") & vbCrLf & rstEvents![naam_klant] & ", " &
        astrCalendarBlocks(bytBlockCounter) = Format$(rstEvents![Time], "hh:nn") & vbCrLf & rstEvents![Naam_Klant] & ", " & _
                                              Left$(rstEvents![Woonplaats], 1) & "." & " [" & rstEvents! & "]"
      Else                                    '<Substitute for [Title]>
        astrCalendarBlocks(bytBlockCounter) = astrCalendarBlocks(bytBlockCounter) & vbNewLine & _
                                                Format$(rstEvents![Time], "hh:nn") & vbCrLf & rstEvents![Naam_Klant] & ", " & _
                                              Left$(rstEvents![Woonplaats], 1) & "." & " [" & rstEvents! & "]"
 
         ' Format$(rstEvents![Time], "hh:nn AM/PM") & vbCrLf & rstEvents![naam_klant] & ", " &
 
      End If
  Next lngEachDateInRange
  'End of CFB added 2-18-10
 
    rstEvents.MoveNext
Loop
 
For bytBlockCounter = 1 To 42                           'blank blocks at start of month
  Select Case bytBlockCounter
    Case Is < bytFirstWeekdayOfMonth
      astrCalendarBlocks(bytBlockCounter) = ""
      ReferenceABlock ctlDayBlock, bytBlockCounter
      'ctlDayBlock.BackColor = 12632256
      ctlDayBlock.BackColor = 8421440
      ctlDayBlock = ""
      ctlDayBlock.Enabled = False
      ctlDayBlock.Tag = ""
    Case Is > bytBlankBlocksBefore + bytDaysInMonth     'blank blocks at end of month
      astrCalendarBlocks(bytBlockCounter) = ""
      ReferenceABlock ctlDayBlock, bytBlockCounter
      'ctlDayBlock.BackColor = 12632256
      ctlDayBlock.BackColor = 8421440
      ctlDayBlock = ""
      ctlDayBlock.Enabled = False
      ctlDayBlock.Tag = ""
        ctlDayBlock.Visible = Not (bytBlankBlocksAfter > 6 And bytBlockCounter > 35)
    Case Else   'blocks that hold days of the month
      bytBlockDayOfMonth = bytBlockCounter - bytBlankBlocksBefore
      ReferenceABlock ctlDayBlock, bytBlockCounter
      lngBlockDate = lngLastOfPreviousMonth + bytBlockDayOfMonth 'block's date
        If bytBlockDayOfMonth < 10 Then
          ctlDayBlock = Space(2) & bytBlockDayOfMonth & _
                        vbNewLine & astrCalendarBlocks(bytBlockCounter)
        Else
          ctlDayBlock = bytBlockDayOfMonth & _
                        vbNewLine & astrCalendarBlocks(bytBlockCounter)
        End If
 
        'If this block is the system date, change its color (CFB 1-25-08)
        If lngBlockDate = lngSystemDate Then
          ctlDayBlock.BackColor = RGB(0, 0, 255)
          ctlDayBlock.ForeColor = QBColor(15)
          Set ctlSystemDateBlock = ctlDayBlock
          blnSystemDateIsShown = True
        Else
          ctlDayBlock.BackColor = QBColor(15)
          ctlDayBlock.ForeColor = 8388608 '====> Added by ADezii on 1/28/2008 (Date
        End If                                  'Text was essentially invisible without it for
          ctlDayBlock.Visible = True            'Block representing current day position)
          ctlDayBlock.Enabled = True
          ctlDayBlock.Tag = lngBlockDate
  End Select
Next
 
'If the system date is in this month, show its events (CFB added 1-25-08)
If blnSystemDateIsShown Then
  PopulateEventsList ctlSystemDateBlock
  PopulateEventsList2 ctlSystemDateBlock
End If
 
 
 
Call PopulateYearListBox    'Added by ADezii on 1/28/2008 - suggested by CFB
 
Exit_PopulateCalendar:
  Exit Sub
Err_PopulateCalendar:
  MsgBox Err.Description, vbExclamation, "Error in PopulateCalendar()"
  Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateCalendar() Sub-Routine", "Called from Multiple Locations")
    Resume Exit_PopulateCalendar
End Sub

[ADezii]

This is not that easy a Task, at least from my perspective. I am currently working on a modification whereas a Variable number of Dates can be passed to the PopulateCalendar() Sub-Routine via Paramarray as an Argument to the Routine which will enable it to hold a Variable number of Arguments. This, however, will not be completed overnight.

[dannyflee]

I understand and will be patient.
If u make any progress i assume you let me know via this topic?

[ADezii]

Definitely, I will keep you posted via this Thread...

[ADezii]

I started development of a System that can plot Independent Dates on the Access Calendar, but a few details first.

1. For the sake of simplicity and brevity, the Model uses a single Table (tblPatients) with the following Design features:
   1. [Patient_ID] - {AutoNumber - Primary Key}
   2. [Last] - {TEXT}
   3. [First] - {TEXT}
   4. [Date1] - {DATE/TIME}
   5. [Date2] - {DATE/TIME}
   6. [Date3] - {DATE/TIME}
2. The concept is as simple as the Table Design and is to: Plot the three Independent Dates on the Access Calendar displaying only the Last Name, a comma, and the First Name Initial, then a closing period as in Smith, J. This concept also needs to be implemented with minimal impact on the existing Code Base.
3. My solution, at last for now, was to pass a Variable number of Arguments, in this case the Names of the Date Fields, to the PopulateCalendar() Sub-Routine via the ParamArray() Statement.
4. I will now post the Code in PopulateCalendar() along with Comments where I feel they are warranted.
   

   Private Sub PopulateCalendar(ParamArray varMyDates())
   On Error GoTo Err_PopulateCalendar
   Dim strFirstOfMonth As String, bytFirstWeekdayOfMonth As Byte, bytBlockCounter As Byte
   Dim bytBlockDayOfMonth As Byte, lngBlockDate As Long, ctlDayBlock As TextBox
   Dim bytDaysInMonth As Byte, bytEventDayOfMonth As Byte, lngFirstOfMonth As Long
   Dim lngLastOfMonth As Long, lngFirstOfNextMonth As Long, lngLastOfPreviousMonth As Long
   Dim lngEventDate As Long, bytBlankBlocksBefore As Byte, bytBlankBlocksAfter As Byte
   Dim astrCalendarBlocks(1 To 42) As String, db As DAO.Database, rstEvents As DAO.Recordset
   Dim strEvent As String
   Dim lngSystemDate As Long   'CFB added 1-25-08
   Dim ctlSystemDateBlock As TextBox, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
   Dim strSQL As String                'Added 4/16/2008
   Dim lngFirstDateInRange As Long     'CFB added 2-18-10
   Dim lngLastDateInRange As Long
   Dim lngEachDateInRange As Long
   Dim strStartTime As String
   Dim varDate As Variant
    
   lngSystemDate = Date        'CFB added 1-25-08
   intMonth = objCurrentDate.Month
   intYear = objCurrentDate.Year
   lstEvents.Visible = False
   lblEventsOnDate.Visible = False
   lblMonth.Caption = MonthAndYear(intMonth, intYear)
    
   'Suggested by NeoPa(Bytes.com) in lieu of Querying the Registry for Short Date Value
   strFirstOfMonth = Format(CDate(intMonth & "/" & intYear), "Short Date")
    
   bytFirstWeekdayOfMonth = WeekDay(strFirstOfMonth)
   lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
   lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
   lngLastOfMonth = lngFirstOfNextMonth - 1
   lngLastOfPreviousMonth = lngFirstOfMonth - 1
   bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
   bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
   bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
    
   Set db = CurrentDb
    
   For Each varDate In varMyDates
     'SQL Statement representing a Single Date Field ([Date]) and not a Date Range
     strSQL = "SELECT * FROM tblPatients WHERE [" & varDate & "] BETWEEN " & lngFirstOfMonth & " AND " & _
               lngLastOfMonth & " ORDER BY [" & varDate & "]"
    
     Set rstEvents = db.OpenRecordset(strSQL)        'Added 4/16/2008
    
     With rstEvents
       Do While Not .EOF
         'CFB added 2-18-10
         lngFirstDateInRange = .Fields(varDate)        '<Substitute for [Start Date], if Date Range>
         If lngFirstDateInRange < lngFirstOfMonth Then
           lngFirstDateInRange = lngFirstOfMonth
         End If
         lngLastDateInRange = .Fields(varDate)         '<Substitute for [End Date], if Date Range>
         If lngLastDateInRange > lngLastOfMonth Then
           lngLastDateInRange = lngLastOfMonth
         End If
    
         For lngEachDateInRange = lngFirstDateInRange To lngLastDateInRange
           bytEventDayOfMonth = (lngEachDateInRange - lngLastOfPreviousMonth)
           bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
             If astrCalendarBlocks(bytBlockCounter) = "" Then      'no existing Text in Array
               astrCalendarBlocks(bytBlockCounter) = ![Last] & ", " & Left$(![First], 1) & "."
             Else
               astrCalendarBlocks(bytBlockCounter) = astrCalendarBlocks(bytBlockCounter) & vbNewLine & _
                                                     ![Last] & ", " & Left$(![First], 1) & "."
             End If
         Next lngEachDateInRange
         'End of CFB added 2-18-10
           .MoveNext
       Loop
     End With
    
     For bytBlockCounter = 1 To 42
       Select Case bytBlockCounter
         Case Is < bytFirstWeekdayOfMonth                    'Blank Blocks at start of Month
           astrCalendarBlocks(bytBlockCounter) = ""
           ReferenceABlock ctlDayBlock, bytBlockCounter
           ctlDayBlock.BackColor = 8421440
           ctlDayBlock = ""
           ctlDayBlock.Enabled = False
           ctlDayBlock.Tag = ""
         Case Is > bytBlankBlocksBefore + bytDaysInMonth     'Blank Blocks at end of Month
           astrCalendarBlocks(bytBlockCounter) = ""
           ReferenceABlock ctlDayBlock, bytBlockCounter
           ctlDayBlock.BackColor = 8421440
           ctlDayBlock = ""
           ctlDayBlock.Enabled = False
           ctlDayBlock.Tag = ""
             ctlDayBlock.Visible = Not (bytBlankBlocksAfter > 6 And bytBlockCounter > 35)
         Case Else   'Blocks that hold Days of the Month
           bytBlockDayOfMonth = bytBlockCounter - bytBlankBlocksBefore
           ReferenceABlock ctlDayBlock, bytBlockCounter
           lngBlockDate = lngLastOfPreviousMonth + bytBlockDayOfMonth
             If bytBlockDayOfMonth < 10 Then
               ctlDayBlock = Space(2) & bytBlockDayOfMonth & _
                             vbNewLine & astrCalendarBlocks(bytBlockCounter)
             Else
               ctlDayBlock = bytBlockDayOfMonth & _
                             vbNewLine & astrCalendarBlocks(bytBlockCounter)
             End If
    
             'If this block is the system date, change its color (CFB 1-25-08)
             If lngBlockDate = lngSystemDate Then
               ctlDayBlock.BackColor = RGB(0, 0, 255)
               ctlDayBlock.ForeColor = QBColor(15)
               Set ctlSystemDateBlock = ctlDayBlock
               blnSystemDateIsShown = True
             Else
               ctlDayBlock.BackColor = QBColor(15)
               ctlDayBlock.ForeColor = 8388608 '====> Added by ADezii on 1/28/2008 (Date
             End If                                  'Text was essentially invisible without it for
               ctlDayBlock.Visible = True            'Block representing current day position)
               ctlDayBlock.Enabled = True
               ctlDayBlock.Tag = lngBlockDate
       End Select
     Next
   Next varDate
    
   'If the system date is in this month, show its events (CFB added 1-25-08)
   If blnSystemDateIsShown Then
     PopulateEventsList ctlSystemDateBlock
   End If
    
   Call PopulateYearListBox    'Added by ADezii on 1/28/2008 - suggested by CFB
   Call SetScrollBars
    
   Exit_PopulateCalendar:
     Exit Sub
   Err_PopulateCalendar:
     MsgBox Err.Description, vbExclamation, "Error in PopulateCalendar()"
     Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateCalendar() Sub-Routine", "Called from Multiple Locations")
       Resume Exit_PopulateCalendar
   End Sub
    

5. PopulateCalendar() now contains a ParamArray() Argument containg one or more Names of Date Fields to be displayed on the Calendar (Code Line# 1).
6. The Variable Declaration in Code Line# 17 will be used to iterate thru the ParamArray() Elements.
7. The For...Each Construct (Code Lines 40 <==> 118) will process each Date Field Name.
8. The SQL Statement (Code Line# 42) needs to be rebuilt for each Element in ParamArray.
9. Using this approach, we can longer use the rstEvents![Date] Syntax to refer to the actual Dates themselves, but we can reference these Fields via the Fields Collection of the Recordset Object as depicted in Code Lines 50 and 54.
10. Is is no longer a simple Call to PopulateCalendar() for now we must pass the Names of the Date Fields to this Sub-Routine, as in:
    

    Call PopulateCalendar("Date1", "Date2", "Date3")
     

11. For now, PopulateEventsList() is hard coded with the actual Dates, but this will be enhanced in the near future, but not now. I am referring to Code Lines 5 to 6 and 13 to 14.
    

    Private Sub PopulateEventsList(ctlDayBlock As Control)
    On Error GoTo Err_PopulateEventsList
    Dim strSQL2 As String
     
    strSQL2 = "SELECT * FROM tblPatients WHERE tblPatients.Date1 = #" & CDate(ctlDayBlock.Tag) & _
              "# OR tblPatients.Date2 = #" & CDate(ctlDayBlock.Tag) & "# OR tblPatients.Date3 = #" & _
              CDate(ctlDayBlock.Tag) & "# ORDER BY tblPatients.Last;"
     
    lstEvents.RowSource = strSQL2
     
    lblEventsOnDate.Caption = Format(ctlDayBlock.Tag, "m-dd-yyyy")
     
    If DCount("*", "tblPatients", "[Date1] = #" & CDate(ctlDayBlock.Tag) & "# OR [Date2] = #" & _
       CDate(ctlDayBlock.Tag) & "#  OR [Date3] = #" & CDate(ctlDayBlock.Tag) & "#") > 0 Then
      lstEvents.Visible = True
      lblEventsOnDate.Visible = True
    Else
      lstEvents.Visible = False
      lblEventsOnDate.Visible = False
    End If
     
    Exit_PopulateEventsList:
      Exit Sub
     
    Err_PopulateEventsList:
      MsgBox Err.Description, vbExclamation, "Error in PopulateEventsList()"
      Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateEventsList() Sub-Routine", _
                     "Called from PopulateCalendar() and all Text Boxes GotFocus() Events")
        Resume Exit_PopulateEventsList
    End Sub

12. Fully realizing how utterly confusing this all must be, I've included the Test DB that I worked on as an Attachment.
13. This Version also has a special effect when a Field (Date Text Box) receives the Focus. A little Bling now and then never hurt anything! (LOL).
14. Have fun, dannyflee!

[PPelle]

A bit OT, but I just can't comprehend why you are cluttering your code with this hack for strFirstOfMonth, when lngFirstOfMonth two lines below is doing the same thing, and working perfectly well all over the world? Am I missing something?

[dannyflee]

Great.

That was pretty quick. I will try to insert the code into my database.

When it fully works i will let you know.
Your example works perfectly:)

[ADezii]

Remember, dannyflee, that PopulateCalendar() is called from multiple locations, namely:

1. Private Sub cmdSyncUp_Click()
2. Private Sub cboMonth_AfterUpdate()
3. cboYear_AfterUpdate()
4. cmdNextMonth_Click()
5. cmdPreviousMonth_Click()
6. Private Sub Form_Activate()

P.S. - Should you not catch one of these Events and activate it, you will run into trouble. The Code was designed to plot three independent Dates, you will have to adjust both the Base Code and the Call for more or less Dates. Have fun and let me know how you make out.

[dannyflee]

I've implemented the code in my database with some few ajustments here and there to get it working on my table.
It works like a charm:)

Thank you so very much for your help.

[ADezii]

You are quite welcome.