Populate Two Dates from One Table in Same Calendar

**ADezii** · Dec 10 '13, 05:24 PM

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 PopulateCalenda r() 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** · Dec 11 '13, 03:50 PM

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

**ADezii** · Dec 11 '13, 06:27 PM

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

**ADezii** · Dec 11 '13, 08:33 PM

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

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}
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.
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 PopulateCalenda r() Sub-Routine via the ParamArray() Statement.

I will now post the Code in PopulateCalenda r() along with Comments where I feel they are warranted.

Code:

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

PopulateCalenda r() now contains a ParamArray() Argument containg one or more Names of Date Fields to be displayed on the Calendar (Code Line# 1).
The Variable Declaration in Code Line# 17 will be used to iterate thru the ParamArray() Elements.
The For...Each Construct (Code Lines 40 <==> 118) will process each Date Field Name.
The SQL Statement (Code Line# 42) needs to be rebuilt for each Element in ParamArray.
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.
Is is no longer a simple Call to PopulateCalenda r() for now we must pass the Names of the Date Fields to this Sub-Routine, as in:
Code:
```
Call PopulateCalendar("Date1", "Date2", "Date3")
```

For now, PopulateEventsL ist() 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.

Code:

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

Fully realizing how utterly confusing this all must be, I've included the Test DB that I worked on as an Attachment.
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).
Have fun, dannyflee!

Attached Files

Calendar With Seperate Dates.zip (60.7 KB, 171 views)

**PPelle** · Dec 11 '13, 11:46 PM

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** · Dec 12 '13, 04:12 AM

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** · Dec 12 '13, 01:50 PM

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

Private Sub cmdSyncUp_Click ()
Private Sub cboMonth_AfterU pdate()
cboYear_AfterUp date()
cmdNextMonth_Cl ick()
cmdPreviousMont h_Click()
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** · Dec 13 '13, 10:42 PM

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** · Dec 14 '13, 12:20 AM

You are quite welcome.