By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
435,165 Members | 850 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 435,165 IT Pros & Developers. It's quick & easy.

Populate Two Dates from One Table in Same Calendar

P: 27
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:

Expand|Select|Wrap|Line Numbers
  1. Private Sub PopulateCalendar()
  2. On Error GoTo Err_PopulateCalendar
  3. Dim strFirstOfMonth As String, bytFirstWeekdayOfMonth As Byte, bytBlockCounter As Byte
  4. Dim bytBlockDayOfMonth As Byte, lngBlockDate As Long, ctlDayBlock As TextBox
  5. Dim bytDaysInMonth As Byte, bytEventDayOfMonth As Byte, lngFirstOfMonth As Long
  6. Dim lngLastOfMonth As Long, lngFirstOfNextMonth As Long, lngLastOfPreviousMonth As Long
  7. Dim lngEventDate As Long, bytBlankBlocksBefore As Byte, bytBlankBlocksAfter As Byte
  8. Dim astrCalendarBlocks(1 To 42) As String, db As DAO.Database, rstEvents As DAO.Recordset
  9. Dim strEvent As String
  10. Dim lngSystemDate As Long   'CFB added 1-25-08
  11. Dim ctlSystemDateBlock As TextBox, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
  12. Dim strSQL As String        'Added 4/16/2008
  13. Dim lngFirstDateInRange As Long     'CFB added 2-18-10
  14. Dim lngLastDateInRange As Long      '
  15. Dim lngEachDateInRange As Long      '
  16. Dim strStartTime As String          '
  17.  
  18.  
  19.  
  20. lngSystemDate = Date        'CFB added 1-25-08
  21. intMonth = objCurrentDate.Month
  22. intYear = objCurrentDate.Year
  23. lstEvents.Visible = True
  24. lblEventsOnDate.Visible = False
  25. lstEvents2.Visible = True
  26. lblMonth.Caption = MonthAndYear(intMonth, intYear)
  27. 'strFirstOfMonth = "1/" & Str(intMonth) & Str(intYear)
  28. strFirstOfMonth = Str(intMonth) & "/1/" & Str(intYear)
  29.  
  30.  
  31. '*************************************************************************
  32.   'ADezii
  33.   'NOTE: Will work in the UK (United Kingdom) and other European Nations
  34.   'strFirstOfMonth = "1/" & Str(intMonth) & Str(intYear)
  35. '*************************************************************************
  36.  
  37. bytFirstWeekdayOfMonth = WeekDay(strFirstOfMonth)
  38. lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
  39. lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
  40. lngLastOfMonth = lngFirstOfNextMonth - 1
  41. lngLastOfPreviousMonth = lngFirstOfMonth - 1
  42. bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
  43. bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
  44. bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54. Set db = CurrentDb
  55.  
  56.  
  57.  
  58.  
  59. strSQL = "SELECT sales1.naam_klant, sales1.woonplaats, sales1.date, tblVisitType.Type, " & _
  60.          "tblVisitType.Code, sales1.time " & _
  61.          "FROM tblVisitType INNER JOIN sales1 ON tblVisitType.TypeID = sales1.TypeID " & _
  62.          "WHERE sales1.date Between #" & CDate(lngFirstOfMonth) & "# And #" & CDate(lngLastOfMonth) & "# " & _
  63.          "ORDER BY  sales1.time, sales1.naam_klant, sales1.woonplaats;"
  64.  
  65.  
  66. Set rstEvents = db.OpenRecordset(strSQL)     'Added 4/16/2008
  67.  
  68.  
  69.  
  70. 'MsgBox IsDate(rstEvents![Date])
  71.  
  72.  
  73. 'With rstEvents
  74.  ' If .BOF And .EOF Then         'NO Records
  75.   '  MsgBox "rstEvents contains 0 Records"
  76. '   Else
  77.   '   .MoveLast: .MoveFirst       'for accurate Record Count
  78.     '   MsgBox "rstEvents consists of " & .RecordCount & " Records"
  79.       '   MsgBox "[Date] " & IIf(IsDate(![Date]), " IS ", " IS NOT ") & _
  80.         '        "recognized by Access as a Valid Date Field"
  81. '   End If
  82.   '   .Close: Set rstEvents = Nothing
  83. ' End With
  84.  
  85. '  Exit Sub
  86.  
  87.  
  88.  
  89. Do While Not rstEvents.EOF
  90.   'CFB added 2-18-10
  91.   'lngFirstDateInRange = CDate(rstEvents![Date])
  92.   lngFirstDateInRange = rstEvents![Date]      '<Substitute for [Start Date]>
  93.   If lngFirstDateInRange < lngFirstOfMonth Then
  94.     lngFirstDateInRange = lngFirstOfMonth
  95.   End If
  96.     'lngLastDateInRange = CDate(rstEvents![Date])
  97.   lngLastDateInRange = rstEvents![Date]         '<Substitute for [End Date]>
  98.   If lngLastDateInRange > lngLastOfMonth Then
  99.     lngLastDateInRange = lngLastOfMonth
  100.   End If
  101.  
  102.   For lngEachDateInRange = lngFirstDateInRange To lngLastDateInRange
  103.     bytEventDayOfMonth = (lngEachDateInRange - lngLastOfPreviousMonth)
  104.     bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
  105.                                               '<Substitute for [Title]>
  106.       If astrCalendarBlocks(bytBlockCounter) = "" Then
  107.        ' astrCalendarBlocks(bytBlockCounter) = Format$(rstEvents![Time], "hh:nn AM/PM") & vbCrLf & rstEvents![naam_klant] & ", " &
  108.         astrCalendarBlocks(bytBlockCounter) = Format$(rstEvents![Time], "hh:nn") & vbCrLf & rstEvents![Naam_Klant] & ", " & _
  109.                                               Left$(rstEvents![Woonplaats], 1) & "." & " [" & rstEvents! & "]"
  110.       Else                                    '<Substitute for [Title]>
  111.         astrCalendarBlocks(bytBlockCounter) = astrCalendarBlocks(bytBlockCounter) & vbNewLine & _
  112.                                                 Format$(rstEvents![Time], "hh:nn") & vbCrLf & rstEvents![Naam_Klant] & ", " & _
  113.                                               Left$(rstEvents![Woonplaats], 1) & "." & " [" & rstEvents! & "]"
  114.  
  115.          ' Format$(rstEvents![Time], "hh:nn AM/PM") & vbCrLf & rstEvents![naam_klant] & ", " &
  116.  
  117.       End If
  118.   Next lngEachDateInRange
  119.   'End of CFB added 2-18-10
  120.  
  121.     rstEvents.MoveNext
  122. Loop
  123.  
  124. For bytBlockCounter = 1 To 42                           'blank blocks at start of month
  125.   Select Case bytBlockCounter
  126.     Case Is < bytFirstWeekdayOfMonth
  127.       astrCalendarBlocks(bytBlockCounter) = ""
  128.       ReferenceABlock ctlDayBlock, bytBlockCounter
  129.       'ctlDayBlock.BackColor = 12632256
  130.       ctlDayBlock.BackColor = 8421440
  131.       ctlDayBlock = ""
  132.       ctlDayBlock.Enabled = False
  133.       ctlDayBlock.Tag = ""
  134.     Case Is > bytBlankBlocksBefore + bytDaysInMonth     'blank blocks at end of month
  135.       astrCalendarBlocks(bytBlockCounter) = ""
  136.       ReferenceABlock ctlDayBlock, bytBlockCounter
  137.       'ctlDayBlock.BackColor = 12632256
  138.       ctlDayBlock.BackColor = 8421440
  139.       ctlDayBlock = ""
  140.       ctlDayBlock.Enabled = False
  141.       ctlDayBlock.Tag = ""
  142.         ctlDayBlock.Visible = Not (bytBlankBlocksAfter > 6 And bytBlockCounter > 35)
  143.     Case Else   'blocks that hold days of the month
  144.       bytBlockDayOfMonth = bytBlockCounter - bytBlankBlocksBefore
  145.       ReferenceABlock ctlDayBlock, bytBlockCounter
  146.       lngBlockDate = lngLastOfPreviousMonth + bytBlockDayOfMonth 'block's date
  147.         If bytBlockDayOfMonth < 10 Then
  148.           ctlDayBlock = Space(2) & bytBlockDayOfMonth & _
  149.                         vbNewLine & astrCalendarBlocks(bytBlockCounter)
  150.         Else
  151.           ctlDayBlock = bytBlockDayOfMonth & _
  152.                         vbNewLine & astrCalendarBlocks(bytBlockCounter)
  153.         End If
  154.  
  155.         'If this block is the system date, change its color (CFB 1-25-08)
  156.         If lngBlockDate = lngSystemDate Then
  157.           ctlDayBlock.BackColor = RGB(0, 0, 255)
  158.           ctlDayBlock.ForeColor = QBColor(15)
  159.           Set ctlSystemDateBlock = ctlDayBlock
  160.           blnSystemDateIsShown = True
  161.         Else
  162.           ctlDayBlock.BackColor = QBColor(15)
  163.           ctlDayBlock.ForeColor = 8388608 '====> Added by ADezii on 1/28/2008 (Date
  164.         End If                                  'Text was essentially invisible without it for
  165.           ctlDayBlock.Visible = True            'Block representing current day position)
  166.           ctlDayBlock.Enabled = True
  167.           ctlDayBlock.Tag = lngBlockDate
  168.   End Select
  169. Next
  170.  
  171. 'If the system date is in this month, show its events (CFB added 1-25-08)
  172. If blnSystemDateIsShown Then
  173.   PopulateEventsList ctlSystemDateBlock
  174.   PopulateEventsList2 ctlSystemDateBlock
  175. End If
  176.  
  177.  
  178.  
  179. Call PopulateYearListBox    'Added by ADezii on 1/28/2008 - suggested by CFB
  180.  
  181. Exit_PopulateCalendar:
  182.   Exit Sub
  183. Err_PopulateCalendar:
  184.   MsgBox Err.Description, vbExclamation, "Error in PopulateCalendar()"
  185.   Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateCalendar() Sub-Routine", "Called from Multiple Locations")
  186.     Resume Exit_PopulateCalendar
  187. End Sub
Dec 10 '13 #1

✓ answered by 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.
    Expand|Select|Wrap|Line Numbers
    1. Private Sub PopulateCalendar(ParamArray varMyDates())
    2. On Error GoTo Err_PopulateCalendar
    3. Dim strFirstOfMonth As String, bytFirstWeekdayOfMonth As Byte, bytBlockCounter As Byte
    4. Dim bytBlockDayOfMonth As Byte, lngBlockDate As Long, ctlDayBlock As TextBox
    5. Dim bytDaysInMonth As Byte, bytEventDayOfMonth As Byte, lngFirstOfMonth As Long
    6. Dim lngLastOfMonth As Long, lngFirstOfNextMonth As Long, lngLastOfPreviousMonth As Long
    7. Dim lngEventDate As Long, bytBlankBlocksBefore As Byte, bytBlankBlocksAfter As Byte
    8. Dim astrCalendarBlocks(1 To 42) As String, db As DAO.Database, rstEvents As DAO.Recordset
    9. Dim strEvent As String
    10. Dim lngSystemDate As Long   'CFB added 1-25-08
    11. Dim ctlSystemDateBlock As TextBox, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
    12. Dim strSQL As String                'Added 4/16/2008
    13. Dim lngFirstDateInRange As Long     'CFB added 2-18-10
    14. Dim lngLastDateInRange As Long
    15. Dim lngEachDateInRange As Long
    16. Dim strStartTime As String
    17. Dim varDate As Variant
    18.  
    19. lngSystemDate = Date        'CFB added 1-25-08
    20. intMonth = objCurrentDate.Month
    21. intYear = objCurrentDate.Year
    22. lstEvents.Visible = False
    23. lblEventsOnDate.Visible = False
    24. lblMonth.Caption = MonthAndYear(intMonth, intYear)
    25.  
    26. 'Suggested by NeoPa(Bytes.com) in lieu of Querying the Registry for Short Date Value
    27. strFirstOfMonth = Format(CDate(intMonth & "/" & intYear), "Short Date")
    28.  
    29. bytFirstWeekdayOfMonth = WeekDay(strFirstOfMonth)
    30. lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
    31. lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
    32. lngLastOfMonth = lngFirstOfNextMonth - 1
    33. lngLastOfPreviousMonth = lngFirstOfMonth - 1
    34. bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
    35. bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
    36. bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
    37.  
    38. Set db = CurrentDb
    39.  
    40. For Each varDate In varMyDates
    41.   'SQL Statement representing a Single Date Field ([Date]) and not a Date Range
    42.   strSQL = "SELECT * FROM tblPatients WHERE [" & varDate & "] BETWEEN " & lngFirstOfMonth & " AND " & _
    43.             lngLastOfMonth & " ORDER BY [" & varDate & "]"
    44.  
    45.   Set rstEvents = db.OpenRecordset(strSQL)        'Added 4/16/2008
    46.  
    47.   With rstEvents
    48.     Do While Not .EOF
    49.       'CFB added 2-18-10
    50.       lngFirstDateInRange = .Fields(varDate)        '<Substitute for [Start Date], if Date Range>
    51.       If lngFirstDateInRange < lngFirstOfMonth Then
    52.         lngFirstDateInRange = lngFirstOfMonth
    53.       End If
    54.       lngLastDateInRange = .Fields(varDate)         '<Substitute for [End Date], if Date Range>
    55.       If lngLastDateInRange > lngLastOfMonth Then
    56.         lngLastDateInRange = lngLastOfMonth
    57.       End If
    58.  
    59.       For lngEachDateInRange = lngFirstDateInRange To lngLastDateInRange
    60.         bytEventDayOfMonth = (lngEachDateInRange - lngLastOfPreviousMonth)
    61.         bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
    62.           If astrCalendarBlocks(bytBlockCounter) = "" Then      'no existing Text in Array
    63.             astrCalendarBlocks(bytBlockCounter) = ![Last] & ", " & Left$(![First], 1) & "."
    64.           Else
    65.             astrCalendarBlocks(bytBlockCounter) = astrCalendarBlocks(bytBlockCounter) & vbNewLine & _
    66.                                                   ![Last] & ", " & Left$(![First], 1) & "."
    67.           End If
    68.       Next lngEachDateInRange
    69.       'End of CFB added 2-18-10
    70.         .MoveNext
    71.     Loop
    72.   End With
    73.  
    74.   For bytBlockCounter = 1 To 42
    75.     Select Case bytBlockCounter
    76.       Case Is < bytFirstWeekdayOfMonth                    'Blank Blocks at start of Month
    77.         astrCalendarBlocks(bytBlockCounter) = ""
    78.         ReferenceABlock ctlDayBlock, bytBlockCounter
    79.         ctlDayBlock.BackColor = 8421440
    80.         ctlDayBlock = ""
    81.         ctlDayBlock.Enabled = False
    82.         ctlDayBlock.Tag = ""
    83.       Case Is > bytBlankBlocksBefore + bytDaysInMonth     'Blank Blocks at end of Month
    84.         astrCalendarBlocks(bytBlockCounter) = ""
    85.         ReferenceABlock ctlDayBlock, bytBlockCounter
    86.         ctlDayBlock.BackColor = 8421440
    87.         ctlDayBlock = ""
    88.         ctlDayBlock.Enabled = False
    89.         ctlDayBlock.Tag = ""
    90.           ctlDayBlock.Visible = Not (bytBlankBlocksAfter > 6 And bytBlockCounter > 35)
    91.       Case Else   'Blocks that hold Days of the Month
    92.         bytBlockDayOfMonth = bytBlockCounter - bytBlankBlocksBefore
    93.         ReferenceABlock ctlDayBlock, bytBlockCounter
    94.         lngBlockDate = lngLastOfPreviousMonth + bytBlockDayOfMonth
    95.           If bytBlockDayOfMonth < 10 Then
    96.             ctlDayBlock = Space(2) & bytBlockDayOfMonth & _
    97.                           vbNewLine & astrCalendarBlocks(bytBlockCounter)
    98.           Else
    99.             ctlDayBlock = bytBlockDayOfMonth & _
    100.                           vbNewLine & astrCalendarBlocks(bytBlockCounter)
    101.           End If
    102.  
    103.           'If this block is the system date, change its color (CFB 1-25-08)
    104.           If lngBlockDate = lngSystemDate Then
    105.             ctlDayBlock.BackColor = RGB(0, 0, 255)
    106.             ctlDayBlock.ForeColor = QBColor(15)
    107.             Set ctlSystemDateBlock = ctlDayBlock
    108.             blnSystemDateIsShown = True
    109.           Else
    110.             ctlDayBlock.BackColor = QBColor(15)
    111.             ctlDayBlock.ForeColor = 8388608 '====> Added by ADezii on 1/28/2008 (Date
    112.           End If                                  'Text was essentially invisible without it for
    113.             ctlDayBlock.Visible = True            'Block representing current day position)
    114.             ctlDayBlock.Enabled = True
    115.             ctlDayBlock.Tag = lngBlockDate
    116.     End Select
    117.   Next
    118. Next varDate
    119.  
    120. 'If the system date is in this month, show its events (CFB added 1-25-08)
    121. If blnSystemDateIsShown Then
    122.   PopulateEventsList ctlSystemDateBlock
    123. End If
    124.  
    125. Call PopulateYearListBox    'Added by ADezii on 1/28/2008 - suggested by CFB
    126. Call SetScrollBars
    127.  
    128. Exit_PopulateCalendar:
    129.   Exit Sub
    130. Err_PopulateCalendar:
    131.   MsgBox Err.Description, vbExclamation, "Error in PopulateCalendar()"
    132.   Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateCalendar() Sub-Routine", "Called from Multiple Locations")
    133.     Resume Exit_PopulateCalendar
    134. End Sub
    135.  
  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:
    Expand|Select|Wrap|Line Numbers
    1. Call PopulateCalendar("Date1", "Date2", "Date3")
    2.  
  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.
    Expand|Select|Wrap|Line Numbers
    1. Private Sub PopulateEventsList(ctlDayBlock As Control)
    2. On Error GoTo Err_PopulateEventsList
    3. Dim strSQL2 As String
    4.  
    5. strSQL2 = "SELECT * FROM tblPatients WHERE tblPatients.Date1 = #" & CDate(ctlDayBlock.Tag) & _
    6.           "# OR tblPatients.Date2 = #" & CDate(ctlDayBlock.Tag) & "# OR tblPatients.Date3 = #" & _
    7.           CDate(ctlDayBlock.Tag) & "# ORDER BY tblPatients.Last;"
    8.  
    9. lstEvents.RowSource = strSQL2
    10.  
    11. lblEventsOnDate.Caption = Format(ctlDayBlock.Tag, "m-dd-yyyy")
    12.  
    13. If DCount("*", "tblPatients", "[Date1] = #" & CDate(ctlDayBlock.Tag) & "# OR [Date2] = #" & _
    14.    CDate(ctlDayBlock.Tag) & "#  OR [Date3] = #" & CDate(ctlDayBlock.Tag) & "#") > 0 Then
    15.   lstEvents.Visible = True
    16.   lblEventsOnDate.Visible = True
    17. Else
    18.   lstEvents.Visible = False
    19.   lblEventsOnDate.Visible = False
    20. End If
    21.  
    22. Exit_PopulateEventsList:
    23.   Exit Sub
    24.  
    25. Err_PopulateEventsList:
    26.   MsgBox Err.Description, vbExclamation, "Error in PopulateEventsList()"
    27.   Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateEventsList() Sub-Routine", _
    28.                  "Called from PopulateCalendar() and all Text Boxes GotFocus() Events")
    29.     Resume Exit_PopulateEventsList
    30. 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!

Share this Question
Share on Google+
9 Replies


ADezii
Expert 5K+
P: 8,638
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.
Dec 10 '13 #2

P: 27
I understand and will be patient.
If u make any progress i assume you let me know via this topic?
Dec 11 '13 #3

ADezii
Expert 5K+
P: 8,638
Definitely, I will keep you posted via this Thread...
Dec 11 '13 #4

ADezii
Expert 5K+
P: 8,638
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.
    Expand|Select|Wrap|Line Numbers
    1. Private Sub PopulateCalendar(ParamArray varMyDates())
    2. On Error GoTo Err_PopulateCalendar
    3. Dim strFirstOfMonth As String, bytFirstWeekdayOfMonth As Byte, bytBlockCounter As Byte
    4. Dim bytBlockDayOfMonth As Byte, lngBlockDate As Long, ctlDayBlock As TextBox
    5. Dim bytDaysInMonth As Byte, bytEventDayOfMonth As Byte, lngFirstOfMonth As Long
    6. Dim lngLastOfMonth As Long, lngFirstOfNextMonth As Long, lngLastOfPreviousMonth As Long
    7. Dim lngEventDate As Long, bytBlankBlocksBefore As Byte, bytBlankBlocksAfter As Byte
    8. Dim astrCalendarBlocks(1 To 42) As String, db As DAO.Database, rstEvents As DAO.Recordset
    9. Dim strEvent As String
    10. Dim lngSystemDate As Long   'CFB added 1-25-08
    11. Dim ctlSystemDateBlock As TextBox, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
    12. Dim strSQL As String                'Added 4/16/2008
    13. Dim lngFirstDateInRange As Long     'CFB added 2-18-10
    14. Dim lngLastDateInRange As Long
    15. Dim lngEachDateInRange As Long
    16. Dim strStartTime As String
    17. Dim varDate As Variant
    18.  
    19. lngSystemDate = Date        'CFB added 1-25-08
    20. intMonth = objCurrentDate.Month
    21. intYear = objCurrentDate.Year
    22. lstEvents.Visible = False
    23. lblEventsOnDate.Visible = False
    24. lblMonth.Caption = MonthAndYear(intMonth, intYear)
    25.  
    26. 'Suggested by NeoPa(Bytes.com) in lieu of Querying the Registry for Short Date Value
    27. strFirstOfMonth = Format(CDate(intMonth & "/" & intYear), "Short Date")
    28.  
    29. bytFirstWeekdayOfMonth = WeekDay(strFirstOfMonth)
    30. lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
    31. lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
    32. lngLastOfMonth = lngFirstOfNextMonth - 1
    33. lngLastOfPreviousMonth = lngFirstOfMonth - 1
    34. bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
    35. bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
    36. bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
    37.  
    38. Set db = CurrentDb
    39.  
    40. For Each varDate In varMyDates
    41.   'SQL Statement representing a Single Date Field ([Date]) and not a Date Range
    42.   strSQL = "SELECT * FROM tblPatients WHERE [" & varDate & "] BETWEEN " & lngFirstOfMonth & " AND " & _
    43.             lngLastOfMonth & " ORDER BY [" & varDate & "]"
    44.  
    45.   Set rstEvents = db.OpenRecordset(strSQL)        'Added 4/16/2008
    46.  
    47.   With rstEvents
    48.     Do While Not .EOF
    49.       'CFB added 2-18-10
    50.       lngFirstDateInRange = .Fields(varDate)        '<Substitute for [Start Date], if Date Range>
    51.       If lngFirstDateInRange < lngFirstOfMonth Then
    52.         lngFirstDateInRange = lngFirstOfMonth
    53.       End If
    54.       lngLastDateInRange = .Fields(varDate)         '<Substitute for [End Date], if Date Range>
    55.       If lngLastDateInRange > lngLastOfMonth Then
    56.         lngLastDateInRange = lngLastOfMonth
    57.       End If
    58.  
    59.       For lngEachDateInRange = lngFirstDateInRange To lngLastDateInRange
    60.         bytEventDayOfMonth = (lngEachDateInRange - lngLastOfPreviousMonth)
    61.         bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
    62.           If astrCalendarBlocks(bytBlockCounter) = "" Then      'no existing Text in Array
    63.             astrCalendarBlocks(bytBlockCounter) = ![Last] & ", " & Left$(![First], 1) & "."
    64.           Else
    65.             astrCalendarBlocks(bytBlockCounter) = astrCalendarBlocks(bytBlockCounter) & vbNewLine & _
    66.                                                   ![Last] & ", " & Left$(![First], 1) & "."
    67.           End If
    68.       Next lngEachDateInRange
    69.       'End of CFB added 2-18-10
    70.         .MoveNext
    71.     Loop
    72.   End With
    73.  
    74.   For bytBlockCounter = 1 To 42
    75.     Select Case bytBlockCounter
    76.       Case Is < bytFirstWeekdayOfMonth                    'Blank Blocks at start of Month
    77.         astrCalendarBlocks(bytBlockCounter) = ""
    78.         ReferenceABlock ctlDayBlock, bytBlockCounter
    79.         ctlDayBlock.BackColor = 8421440
    80.         ctlDayBlock = ""
    81.         ctlDayBlock.Enabled = False
    82.         ctlDayBlock.Tag = ""
    83.       Case Is > bytBlankBlocksBefore + bytDaysInMonth     'Blank Blocks at end of Month
    84.         astrCalendarBlocks(bytBlockCounter) = ""
    85.         ReferenceABlock ctlDayBlock, bytBlockCounter
    86.         ctlDayBlock.BackColor = 8421440
    87.         ctlDayBlock = ""
    88.         ctlDayBlock.Enabled = False
    89.         ctlDayBlock.Tag = ""
    90.           ctlDayBlock.Visible = Not (bytBlankBlocksAfter > 6 And bytBlockCounter > 35)
    91.       Case Else   'Blocks that hold Days of the Month
    92.         bytBlockDayOfMonth = bytBlockCounter - bytBlankBlocksBefore
    93.         ReferenceABlock ctlDayBlock, bytBlockCounter
    94.         lngBlockDate = lngLastOfPreviousMonth + bytBlockDayOfMonth
    95.           If bytBlockDayOfMonth < 10 Then
    96.             ctlDayBlock = Space(2) & bytBlockDayOfMonth & _
    97.                           vbNewLine & astrCalendarBlocks(bytBlockCounter)
    98.           Else
    99.             ctlDayBlock = bytBlockDayOfMonth & _
    100.                           vbNewLine & astrCalendarBlocks(bytBlockCounter)
    101.           End If
    102.  
    103.           'If this block is the system date, change its color (CFB 1-25-08)
    104.           If lngBlockDate = lngSystemDate Then
    105.             ctlDayBlock.BackColor = RGB(0, 0, 255)
    106.             ctlDayBlock.ForeColor = QBColor(15)
    107.             Set ctlSystemDateBlock = ctlDayBlock
    108.             blnSystemDateIsShown = True
    109.           Else
    110.             ctlDayBlock.BackColor = QBColor(15)
    111.             ctlDayBlock.ForeColor = 8388608 '====> Added by ADezii on 1/28/2008 (Date
    112.           End If                                  'Text was essentially invisible without it for
    113.             ctlDayBlock.Visible = True            'Block representing current day position)
    114.             ctlDayBlock.Enabled = True
    115.             ctlDayBlock.Tag = lngBlockDate
    116.     End Select
    117.   Next
    118. Next varDate
    119.  
    120. 'If the system date is in this month, show its events (CFB added 1-25-08)
    121. If blnSystemDateIsShown Then
    122.   PopulateEventsList ctlSystemDateBlock
    123. End If
    124.  
    125. Call PopulateYearListBox    'Added by ADezii on 1/28/2008 - suggested by CFB
    126. Call SetScrollBars
    127.  
    128. Exit_PopulateCalendar:
    129.   Exit Sub
    130. Err_PopulateCalendar:
    131.   MsgBox Err.Description, vbExclamation, "Error in PopulateCalendar()"
    132.   Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateCalendar() Sub-Routine", "Called from Multiple Locations")
    133.     Resume Exit_PopulateCalendar
    134. End Sub
    135.  
  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:
    Expand|Select|Wrap|Line Numbers
    1. Call PopulateCalendar("Date1", "Date2", "Date3")
    2.  
  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.
    Expand|Select|Wrap|Line Numbers
    1. Private Sub PopulateEventsList(ctlDayBlock As Control)
    2. On Error GoTo Err_PopulateEventsList
    3. Dim strSQL2 As String
    4.  
    5. strSQL2 = "SELECT * FROM tblPatients WHERE tblPatients.Date1 = #" & CDate(ctlDayBlock.Tag) & _
    6.           "# OR tblPatients.Date2 = #" & CDate(ctlDayBlock.Tag) & "# OR tblPatients.Date3 = #" & _
    7.           CDate(ctlDayBlock.Tag) & "# ORDER BY tblPatients.Last;"
    8.  
    9. lstEvents.RowSource = strSQL2
    10.  
    11. lblEventsOnDate.Caption = Format(ctlDayBlock.Tag, "m-dd-yyyy")
    12.  
    13. If DCount("*", "tblPatients", "[Date1] = #" & CDate(ctlDayBlock.Tag) & "# OR [Date2] = #" & _
    14.    CDate(ctlDayBlock.Tag) & "#  OR [Date3] = #" & CDate(ctlDayBlock.Tag) & "#") > 0 Then
    15.   lstEvents.Visible = True
    16.   lblEventsOnDate.Visible = True
    17. Else
    18.   lstEvents.Visible = False
    19.   lblEventsOnDate.Visible = False
    20. End If
    21.  
    22. Exit_PopulateEventsList:
    23.   Exit Sub
    24.  
    25. Err_PopulateEventsList:
    26.   MsgBox Err.Description, vbExclamation, "Error in PopulateEventsList()"
    27.   Call LogErrors(Err.Number, Err.Description, "frmCalendar", "PopulateEventsList() Sub-Routine", _
    28.                  "Called from PopulateCalendar() and all Text Boxes GotFocus() Events")
    29.     Resume Exit_PopulateEventsList
    30. 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!
Attached Files
File Type: zip Calendar With Seperate Dates.zip (60.7 KB, 65 views)
Dec 11 '13 #5

P: 17
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?
Dec 11 '13 #6

P: 27
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:)
Dec 12 '13 #7

ADezii
Expert 5K+
P: 8,638
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.
Dec 12 '13 #8

P: 27
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.
Dec 13 '13 #9

ADezii
Expert 5K+
P: 8,638
You are quite welcome.
Dec 14 '13 #10

Post your reply

Sign in to post your reply or Sign up for a free account.