Recurring Data and Yearly Calender Summary 1

[spartansFC]

Hi

I've used Duane Hookems recurring database example and created a form that populates booking information for a child's attendance from April 14 2013 to March 31 2014, the fields are:

dteSessionDates
ysnCurrentSession
lngChildID
lngClubID
lngPickedupFrom
lngSessionType
curSessionCost

and the data looks like

14/04/2013 True 100 100 100 1 10.00
15/04/2013 False 100 100 100 1 10.00
16/04/2013 False 100 100 100 1 10.00

so i can do the above, i've seen a great example of a yearly calender which i've attached where you can see which sessions the child is booked into. I know how to do crosstab queries but i'm not sure how to:

A: get the form to show all dates as days (Su, Mo, Tu, We... etc) along the top even when the child hasn't booked in for that day

I thought i might need a seperate table and connect it via dteSessionDates but that doesn't seem to work, it only shows the sessions the child is booked in for.

Has anyone ever tried to do a summary form like the one attached?

Any ideas

thanks

Mikie

 

[dhookom]

I have some calendar type reports at my sample reports page. If you want a form to look like this it would be much more difficult.

You can also create crosstabs with set column headings.

Duane
Hook'D on Access
MS Access MVP

 

[spartansFC]

Hi Duane

thanks for the web link, i've looked at your report examples, i think i'll need to have a good look at them.

I've searched around and found various other examples of a mini calendar, it will be difficult but i'll get there.

Mikie

 

[spartansFC]

I think where i need to start is by:

creating a form with 42 unbound text boxes but the text boxes need to be in a row, most of the examples have them in a matrix of 6 rows x 7 columns.

Then i need to create a module which loops through all 42 boxes putting the correct date into each box... somehow

 

[spartansFC]

So i've got a bit further, i've managed by use of an example managed to create a step in the right direction:

i used the following:

How to Create your own Basic Calendar
Create a form that looks like a calendar by Adding:
1 unbound text box .Name it FirstDate Set format to mmmm\ /yyyy
Create 42 unbound text boxes name them D0,D1,D2 >>>>D40, D41 , 6 rows 7 columns
D0,D1,D2,D3,D4,D5,D6,
D7,D8,D9,D10,D11,D12,D13,
D14,D15,D16,D17,D18,D19,D20, You get the Idea!
(Note) don’t do them 1 at a time create 7 then copy and paste!
1 label placed above the textboxes with caption SUN Mon TUE etc..

and the code is

Private Sub Command87_Click()
    Me!FirstDate = DateAdd("m", 1, FirstDate) 'increase by 1 month
    Call filldates
End Sub

Private Sub Command88_Click()
    Me!FirstDate = DateAdd("m", -1, FirstDate) 'increase by 1 month
    Call filldates
End Sub

Private Sub Form_Open(Cancel As Integer)
Me![FirstDate] = Date    'set starting date to current date
Call filldates   'call function that fills in calendar
End Sub

Private Function filldates()
Dim curday As Variant, curbox As Integer
curday = DateSerial(Year(Me![FirstDate]), Month(Me![FirstDate]), 1) 'first day of month
curday = DateAdd("d", 1 - Weekday(curday), curday) 'back to sunday
For curbox = 0 To 41 'need to loop thru 42 textboxes
Me("D" & curbox) = Day(curday)
Me("D" & curbox).Visible = False
If Month(curday) = Month(Me!FirstDate) Then Me("D" & curbox).Visible = True
curday = curday + 1 'nextday
Next curbox
End Function

so what happens is i can click forward and back via command 87 and command 88, the days change to the correct days of the week, i just need to work out:

how to have the months down the side
colour code weekend days, school holidays, bank holidays (think i need a separate table for this and link it in via a query somehow)
have the calender linked to the crosstab query

I'm getting there slowly but surely

 

[MajP]

Unfortunately Access is just becoming more and more behind the times. If you do something like this in VB.net it would be trivial to do with a grid control. You can try a flexgrid control in access, but I am never successful with registering them and they do not port over well. So my trick would be to do this unbounded, but that would be a huge manual pain. Especially ensuring you get the names correct. Assume you need a whole year 12 rows by 36 columns. (You show 35 columns, but If a month would start on a Friday and it was 31 days long then it would span to the 36 column.)

So I build the grid and name the cells appropriately. Example
txtJan1, txtJan2, ...txtJan36
txtFeb1, txtFeb2,... txtFeb36
....
txtDec1, txtDec2,... txtDec36

But I build the form in code and do all the formatting in code. If I do not like the way it comes out I change the formatting in code and build it again. This saves me a ton of frustration trying to format and update all of those controls.

Now it is pretty easy to read a recordset, figure out the proper row (month), and the day offset for the column. Then you can highlight the cells as appropriate.

Build a form and grid by code

Public Sub Main()
  CreateForm
  DoCmd.OpenForm "frmYearCalendar", acDesign
  CreateGridControls Forms("frmYearCalendar")
  formatGrid Forms("frmYearCalendar")
End Sub

Public Sub CreateForm()
  Dim frm As Access.Form
  Dim strName As String
  Dim frmExists As AccessObject
  Set frm = Application.CreateForm
  frm.Visible = True
  strName = frm.Name
  DoCmd.Close acForm, frm.Name, acSaveYes
  For Each frmExists In CurrentProject.AllForms
    If frmExists.Name = "frmYearCalendar" Then DoCmd.DeleteObject acForm, "frmYearCalendar"
  Next frmExists
  DoCmd.Rename "frmYearCalendar", acForm, strName
End Sub
Public Sub CreateGridControls(frm As Access.Form)
  Dim ctrl As Access.TextBox
  Dim I As Integer
  'Assume the Grid is 12 by 36
  frm.SetFocus
  For I = 1 To (12 * 36)
    Set ctrl = Application.CreateControl(frm.Name, acTextBox, acDetail)
    ctrl.Name = "txt" & I
  Next I
End Sub
Public Sub formatGrid(frm As Access.Form)
  Const ctlWidth = (0.25 * 1440)
  Const ctlHeight = (0.25 * 1440)
  Const conStartLeft = (0.5 * 1440)
  Const conStartTop = (1 * 1440)
  
  Dim startLeft As Long
  Dim startTop As Long
  Dim lngRow As Long
  Dim lngCol As Long
  Dim intCounter As Long
  Dim ctl As Access.Control
  Dim aMonths() As Variant
  
  aMonths = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  startLeft = conStartLeft
  startTop = conStartTop
  
  For lngRow = 1 To 12
     For lngCol = 1 To 36
     intCounter = intCounter + 1
     Set ctl = frm.Controls("txt" & intCounter)
     With ctl
         .Height = ctlHeight
         .Width = ctlWidth
         .Left = startLeft
         .Top = startTop
         .FontSize = 8
         .Visible = True
         .Tag = aMonths(lngRow - 1) & ";" & lngCol
         .Name = "txt" & aMonths(lngRow - 1) & lngCol
         'Add other formatting as necessary
         'Define the function here that they do when clicked.
         .OnClick = "=gridClick()"
       End With
       startLeft = startLeft + ctlWidth
     Next lngCol
     startLeft = conStartLeft
     startTop = startTop + ctl.Height
  Next lngRow
End Sub

Public Function gridClick()
  'This just demoes a single function that fires when any of the grid text boxes are clicked
  Dim ctl As Access.Control
  Dim strMonth As String
  Dim strCol As String
  Set ctl = Screen.ActiveControl
  strMonth = Replace(Split(ctl.Tag, ";")(0), "txt", "")
  strCol = Split(ctl.Tag, ";")(1)
  MsgBox ctl.Name & ": Month " & strMonth & " Column " & strCol
   If ctl.ForeColor = vbRed Then
     ctl.ForeColor = vbBlack
    Else
      ctl.ForeColor = vbRed
    End If
End Function

For Standard holidays you can use the following, but for school specific you would then just read another recordset of stored holidays and highlight as appropriate.

For the federal Holidays

Public Function isHoliday(ByVal dtmDate As Date) As Boolean
   Dim intYear As Integer
   Dim intMonth As Integer
   Dim intDay As Integer
   Dim intWeekDay As Integer
   intYear = Year(dtmDate)
   intMonth = Month(dtmDate)
   intDay = Day(dtmDate)
   intWeekDay = Weekday(dtmDate)
   
   'If you do not care if a holiday falls on a weekend
   'If intWeekDay > 1 And intWeekDay < 7 Then exit Function
    'New Years Day
     If DatePart("y", dtmDate) = 1 Then
       isHoliday = True
       Exit Function
     End If
    'ML King 3rd Monday of Jan
       If DayOfNthWeek(intYear, 1, 3, vbMonday) = dtmDate Then
          isHoliday = True
          Exit Function
       End If
    'Presidents Day  3rd Monday of Feb
    If DayOfNthWeek(intYear, 2, 3, vbMonday) = dtmDate Then
          isHoliday = True
          Exit Function
    End If
    'Memorial Day    Last Monday of May
      If LastMondayInMonth(intYear, 5) = dtmDate Then
         isHoliday = True
         Exit Function
      End If
    'Independance Day
       If intMonth = 7 And intDay = 4 Then
          isHoliday = True
          Exit Function
       End If
    'Labor Day   1st Monday of Sep
        If DayOfNthWeek(intYear, 9, 1, vbMonday) = dtmDate Then
          isHoliday = True
          Exit Function
       End If
    'Columbus Day    2nd Monday of Oct
        If DayOfNthWeek(intYear, 10, 2, vbMonday) = dtmDate Then
          isHoliday = True
          Exit Function
       End If
    ' Veteranss Day
    ' Although originally scheduled for celebration on November 11,
    ' starting in 1971 Veterans Day was moved to the fourth Monday of October.
    ' In 1978 it was moved back to its original celebration on November 11.
       If intMonth = 11 And intDay = 11 Then
          isHoliday = True
          Exit Function
       End If
    'Thanksgiving Day  4th Thursday of Nov
       If DayOfNthWeek(intYear, 11, 4, vbThursday) = dtmDate Then
          isHoliday = True
          Exit Function
       End If
    'CHRISTMAS
        If intMonth = 12 And intDay = 25 Then isHoliday = True
End Function
Public Function DayOfNthWeek(intYear As Integer, intMonth As Integer, N As Integer, vbDayOfWeek As Integer) As Date
  'Thanksgiving is the 4th thursday in November(11)
  'dayOfNthWeek(theYear,11,4,vbThursday)
   DayOfNthWeek = DateSerial(intYear, intMonth, (8 - Weekday(DateSerial(intYear, intMonth, 1), _
 (vbDayOfWeek + 1) Mod 8)) + ((N - 1) * 7))
End Function
Function LastMondayInMonth(intYear As Integer, intMonth As Long) As Date
    'Used for memorial day
    Dim LastDay As Date
    'define last day of the month of interest:
    LastDay = DateSerial(intYear, intMonth + 1, 0)
    'use to get last monday:
    LastMondayInMonth = LastDay - Weekday(LastDay, vbMonday) + 1
End Function

 

[dhookom]

I think you can do this without any code using a crosstab query and some conditional formatting. I'm not sure what causes the different colors but you can create a continuous form based on this query:

TRANSFORM Avg(tblSpartans.ysnCurrentSession) AS AvgOfysnCurrentSession
SELECT Year([dteSessionDates]) AS YR, Month([dteSessionDates]) AS MTH
FROM tblSpartans
GROUP BY Year([dteSessionDates]), Month([dteSessionDates])
ORDER BY Year([dteSessionDates])
PIVOT [DteSessionDates]-DateAdd("d",-Weekday(DateSerial(Year([dteSessionDates])+2,Month([dteSessionDates]),1)),DateSerial(Year([dteSessionDates]),Month([dteSessionDates]),1));

You get a recordset like the following:

[pre]
YR MTH 1 2 3 4 5 6 7 8 9 10
2012 3 -1 0 -1 -1
2012 4 -1 0 0 0 0 -1 -1 -1
2012 5 -1 0 0 0 -1 0
2012 6 0 0 0 -1 0 -1 0 0 -1 -1
2012 7 -1 -1 0 0 0 -1 0 -1
2012 8 0 0 -1 0 0
2012 9 0 0 0 -1 0 0 0 0 0
2012 10 0 0 0 -1 -1 -1 0
2012 11 -1 -1 -1 -1
2012 12 0 -1 0 0 -1 0 0 -1 0
2013 1 -1 -1 -1 -1 0 0
2013 2 0 -1 -1 0 0 -1 0 0 0 0
2013 3 0 -1 0 -1 0 -1 -1 0 0 -1
2013 4 -1 -1 -1 -1 -1 0
[/pre]

You can actually show whatever value you want in the columns.


Duane
Hook'D on Access
MS Access MVP

 

[spartansFC]

Thanks MajP and Duane, i haven't had a chance to try out all the work you've sent me
stuck with other work stuff.

I'll try and set up the form this week and let you know how i get on.

Thanks for sending so much information

Mikie

 

[spartansFC]

Ok, so i've fallen at the first hurdle. How do i implement your code MajP to create this form.

Do i create a command button which starts the code off then it creates the form for me?

Where do i put MajP's code in order for it to run?

I am so stuck at the minute

 

[MajP]

This is a little different in that you are using this code at design time, not at runtime. So you would just put this code in a standard module (not a form module) and then you run the main sub from the vba window. It will build you a form that you would then save. Of course you could do all of this manually, but that is a lot of controls to build, name, and format.

 

[spartansFC]

Thanks for the help MajP, i pasted all the code into a new module and ran the module by typing in the immediate window "CreateForm":

it does create a form frmYearCalender but when i view it, it's blank, there's no text boxes or anything

 

[MajP]

That only creates the form. Need to run "Main". That adds the controls.

 

[MajP]

BTW. This grid is not actually correct. You really need to double the amount of rows. You actually need the first row for each month to be a place to put the the label for the day (1,2,3...). The second row is the textbox where you would then put whatever information you want for that date. Your image shows the second row as empty with some colored. But you could put some short text in there.

 

[spartansFC]

Oh my god, how fantastic, never knew you could create forms this way. It does save a lot of manual text box creating.

So i slightly changed the grid structure to 12x42, i was just going to try and use the code:

Private Function filldates()
Dim curday As Variant, curbox As Integer
curday = DateSerial(Year(Me![FirstDate]), Month(Me![FirstDate]), 1) 'first day of month
curday = DateAdd("d", 1 - Weekday(curday), curday) 'back to sunday
For curbox = 0 To 41 'need to loop thru 42 textboxes
Me("D" & curbox) = Day(curday)
Me("D" & curbox).Visible = False
If Month(curday) = Month(Me!FirstDate) Then Me("D" & curbox).Visible = True
curday = curday + 1 'nextday
Next curbox
End Function

the above code does work for 1 line only as there's only 1 for loop, i'd need to add a 2nd for loop within a for loop i believe, so it would be pretty similar to how you helped me create all those unbound boxes, i'd use:

Private Function filldates()
Dim curday As Variant, curbox As Integer
curday = DateSerial(Year(Me![FirstDate]), Month(Me![FirstDate]), 1) 'first day of month
curday = DateAdd("d", 1 - Weekday(curday), curday) 'back to sunday
For lngRow = 1 To 12
      For curbox = 0 To 41 'need to loop thru 42 textboxes
      Me("txt" & curbox) = Day(curday)
      Me("D" & curbox).Visible = False
           If Month(curday) = Month(Me!FirstDate) Then Me("D" & curbox).Visible = True
           curday = curday + 1 'nextday
      Next curbox
Next lngRow
EndSub

i think that's roughly what i need to do, think i need to change the

Me."D" & curbox

to

Me."txt" & aMonths(lngRow - 1) & lngCol)

would the above rough design fill up the txt boxes with the respective dates

 

[MajP]

So here is the correct code to build this form.

Option Compare Database
Option Explicit
Public Sub Main()
  CreateForm
  DoCmd.OpenForm "frmYearCalendar", acDesign
  formatGrid Forms("frmYearCalendar")
End Sub
Public Sub CreateForm()
  Dim frm As Access.Form
  Dim strName As String
  Dim frmExists As AccessObject
  Set frm = Application.CreateForm
  frm.Visible = True
  strName = frm.Name
  DoCmd.Close acForm, frm.Name, acSaveYes
  For Each frmExists In CurrentProject.AllForms
    If frmExists.Name = "frmYearCalendar" Then
      DoCmd.Close acForm, "frmYearCalendar"
      DoCmd.DeleteObject acForm, "frmYearCalendar"
    End If
  Next frmExists
  DoCmd.Rename "frmYearCalendar", acForm, strName
End Sub

Public Sub formatGrid(frm As Access.Form)
  Const ctlWidth = (0.25 * 1440)
  Const ctlHeight = (0.25 * 1440)
  Const conStartLeft = (0.5 * 1440)
  Const conStartTop = (1 * 1440)
  
  Dim startLeft As Long
  Dim startTop As Long
  Dim lngRow As Long
  Dim lngCol As Long
  Dim intCounter As Long
  Dim ctl As Access.Control
  Dim aMonths() As Variant
  
  aMonths = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  startLeft = conStartLeft
  startTop = conStartTop
  '12 Textbox rows, 12 label rows
  For lngRow = 1 To 24
     For lngCol = 1 To 36
    ' Debug.Print lngRow & " mod" & lngRow Mod 2
     If lngRow Mod 2 = 0 Then
       'text box row event row
        Set ctl = Application.CreateControl(frm.Name, acTextBox, acDetail)
        With ctl
         .Height = ctlHeight
         .Width = ctlWidth
         .Left = startLeft
         .Top = startTop
         .FontSize = 8
         .Visible = True
         .Tag = aMonths(lngRow / 2 - 1) & ";" & lngCol
         .Name = "txt" & aMonths(lngRow / 2 - 1) & lngCol
         'Add other formatting as necessary
         'Define the function here that they do when clicked.
         .OnClick = "=gridClick()"
       End With
     Else
       'label row
       Set ctl = Application.CreateControl(frm.Name, acLabel, acDetail)
       With ctl
         .Height = ctlHeight
         .Width = ctlWidth
         .Left = startLeft
         .Top = startTop
         .FontSize = 8
         .Visible = True
         .Tag = aMonths((lngRow + 1) / 2 - 1) & ";" & lngCol
         'Debug.Print "lbl" & aMonths((lngRow + 1) / 2 - 1) & lngCol
         .BackStyle = 1
         .BackColor = -2147483616
         .BorderStyle = 1
         .Name = "lbl" & aMonths((lngRow + 1) / 2 - 1) & lngCol
         'Add other formatting as necessary
         
       End With
     End If
     startLeft = startLeft + ctlWidth
     Next lngCol
     startLeft = conStartLeft
     startTop = startTop + ctl.Height
  Next lngRow
End Sub

Public Function gridClick()
  'This just demoes a single function that fires when any of the grid text boxes are clicked
  Dim ctl As Access.Control
  Dim strMonth As String
  Dim strCol As String
  Set ctl = Screen.ActiveControl
  strMonth = Replace(Split(ctl.Tag, ";")(0), "txt", "")
  strCol = Split(ctl.Tag, ";")(1)
  MsgBox ctl.Name & ": Month " & strMonth & " Column " & strCol
   If ctl.ForeColor = vbRed Then
     ctl.ForeColor = vbBlack
    Else
      ctl.ForeColor = vbRed
    End If
End Function

It builds this entire form except for the month labels down the side and the day of the week labels along the top and the date time picker. That only takes a couple of minutes to do. I only showed the first two months.

Here is the code in the form you need to add after you build the form

Private Sub dtpYear_Change()
 FillMonthLabels Me, Year(dtpYear.Value)
End Sub

Private Sub Form_Load()
 FillMonthLabels Me, Year(dtpYear.Value)
End Sub

I put additional code into a seperate model, to control the form. This is because in case I want to rebuild the form I will have all the code. This puts the correct labels and formats holidays.

Public Sub FillMonthLabels(frm As Access.Form, theYear As Integer)
  Dim ctl As Access.Label
  Dim m As Integer
  Dim I As Integer
  Dim aMonths() As Variant
  Dim theMonth As Variant
  Dim dtStartDate As Date     'First of month
  Dim iDays As Integer        'Days in month
  Dim iOffset As Integer      'Offset to first label for month.
  'Loop controller.
  Dim iDay As Integer         'Day under consideration.
  Dim monthCounter As Integer
  Const ctlBackColor = -2147483616
  aMonths = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  For monthCounter = 1 To 12
    dtStartDate = DateSerial(theYear, monthCounter, 1) 'First of month
    iDays = Day(DateAdd("m", 1, dtStartDate) - 1)   'Days in month.
    iOffset = Weekday(dtStartDate, vbSaturday) - 1   'Offset to first label for month.

     For I = 1 To 36
       Set ctl = frm.Controls("lbl" & aMonths(monthCounter - 1) & I)
       ctl.Caption = ""
       ctl.BackColor = ctlBackColor
       iDay = I - iOffset
       If iDay > 0 And iDay <= iDays Then
         ctl.Caption = I - iOffset
         If isHoliday(dtStartDate + I - 1) Then ctl.BackColor = vbGreen
       End If
     Next I
  Next monthCounter
End Sub

Now this form also needs procedure to fill the text box associated with the day. I did not do that because I would need specifics on the table to read and what information or formatting for the textbox.

 

[MajP]

BTW you can format the date time picker to scroll through years. So it only shows the year and has an updown control. You do this by right clicking on it and seleting DTPObject > Properties and choosing custom format. In the custom format fields put yyyy in lower case. Then check the box "updown". This basically creates a year only picker.

 

[MajP]

To demonstrate filling the textboxes from a recordset. I picked the orders table from northwind. It has an order date field and a ShipName. I put a combobox of the ship names on top of the form. And added this code.

Private Sub cmboShipTo_AfterUpdate()
 FillTextBoxes Me, Me.cmboShipTo, Year(dtpYear.Value)
End Sub

I added this code to the module

Public Sub FillTextBoxes(frm As Access.Form, shipName As String, theYear As Integer)
  Dim ctl As Access.TextBox
  Dim rs As DAO.Recordset
  Dim strSql As String
  Dim strMonth As String
  Dim intDay As Integer
  Dim orderdate As Date
  Dim dtStartdate As Date
  Dim iOffset As Integer
  
  strSql = "Select * from qryOrders where ShipName = '" & shipName & "' "
  strSql = strSql & "AND year(orderDate) = " & theYear
  Set rs = CurrentDb.OpenRecordset(strSql)
  clearTextBoxes frm
  
  Do While Not rs.EOF
    orderdate = rs!orderdate
    strMonth = Format(orderdate, "mmm")
    intDay = Day(orderdate)
    dtStartdate = DateSerial(theYear, Month(orderdate), 1) 'First of month
    iOffset = Weekday(dtStartdate, vbSaturday) - 1   'Offset to first label for month.
    Set ctl = frm.Controls("txt" & strMonth & intDay + iOffset)
    ctl.Value = "Ord"
    rs.MoveNext
  Loop
 
End Sub
Public Sub clearTextBoxes(frm As Access.Form)
  Dim ctl As Access.TextBox
  Dim I As Integer
  Dim amonths() As Variant
  Dim theMonth As Variant
  Dim monthCounter As Integer
  amonths = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
 
  For monthCounter = 1 To 12
     For I = 1 To 36
       Set ctl = frm.Controls("txt" & amonths(monthCounter - 1) & I)
       ctl.Value = ""
     Next I
  Next monthCounter
End Sub

So when you pick a year and a ship to name it fills the text boxes with "ord" on the dates they placed an order

So the final step is when you click on a textbox it should open a pop up form for that date to let you add, delete, or edit the information for that date. The click event is already there, you need to then edit the common click event function.

 

[MajP]

also the code for formatting the holidays was incorrect. Should be

If isHoliday(dtStartdate + I - iOffset - 1) Then ctl.BackColor = vbGreen

 

[spartansFC]

Thank you so much MajP for creating all this code, forms and modules for me. I really appreciate it.

Hopefully i won't be asking any more questions. Was this easy for you to do, i found it really difficult, i understand most of the code
but wouldn't have been able to write it myself.

 

[MajP]

I have so much code samples that I have written in the past, and a pretty organized library of code. So I already had an example of making a dynamic grid, lots of calendar code, and the holiday code. So mainly just had to pull the existing code out and tweak it a little. But I have written so much code that what I can do in a few minutes takes most developers hours or days.