MS Access Calendar

[ADezii]

Download the Attachment for what I feel is a workable Demo which you can tweak to your own needs. Be advised that you may have to swap Code Lines 21 and 26, since you are in the UK. Only you can make that determination. Good Luck and let me know how you make out.

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 Control
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 Database, rstEvents As Recordset
Dim strSelectEvents As String, strEvent As String, strPlatoons As String
Dim lngSystemDate As Long  'CFB added 1-25-08
Dim ctlSystemDateBlock As Control, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
Dim strSQL As String    'Added 4/16/2008
Dim blnRetVal, intNumOfRecs As Integer

lngSystemDate = Date    'CFB added 1-25-08
intMonth = objCurrentDate.Month
intYear = objCurrentDate.Year
lstEvents.Visible = False
lblEventsOnDate.Visible = False
lblMonth.Caption = MonthAndYear(intMonth, 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 * From tbl_employees_TEMP Where tbl_employees_TEMP.[LeaveDateFrom] Between " & _
          lngFirstOfMonth & " And " & lngLastOfMonth & " ORDER BY tbl_employees_TEMP.[LeaveDateFrom], " & _
          "tbl_employees_TEMP.[FullName];"

Set rstEvents = db.OpenRecordset(strSQL)    'Added 4/16/2008

Do While Not rstEvents.EOF
  strEvent = rstEvents![FullName]
  bytEventDayOfMonth = (rstEvents![LeaveDateFrom] - lngLastOfPreviousMonth)
  bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
    If astrCalendarBlocks(bytBlockCounter) <> "" Then
      astrCalendarBlocks(bytBlockCounter) = _
      astrCalendarBlocks(bytBlockCounter) & vbNewLine & strEvent
    Else
      astrCalendarBlocks(bytBlockCounter) = strEvent
    End If
    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 = ""
      ctlDayBlock.Enabled = False
      ctlDayBlock.Tag = ""
    Case Is > bytBlankBlocksBefore + bytDaysInMonth 'blank blocks at end of month
      astrCalendarBlocks(bytBlockCounter) = ""
      ReferenceABlock ctlDayBlock, bytBlockCounter
      ctlDayBlock.BackColor = 12632256
      ctlDayBlock = ""
      ctlDayBlock.Enabled = False
      ctlDayBlock.Tag = ""
        If bytBlankBlocksAfter > 6 And bytBlockCounter > 35 Then
          ctlDayBlock.Visible = False
        End If
    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 = QBColor(13)
          ctlDayBlock.ForeColor = QBColor(15)
          Set ctlSystemDateBlock = ctlDayBlock
          blnSystemDateIsShown = True
        Else
          ctlDayBlock.BackColor = 16777215
          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
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 inPopulateCalendar()"
  Resume Exit_PopulateCalendar
End Sub

[NeoPa]

Space is not an issue so the additional column is not a problem.

If that's your opinion, then I strongly recommend checking out Normalisation and Table structures. You won't find many experienced database professionals who agree with you.

[edsuk]

ADezii

Thanks for the Calendar Db, exactly what was required. Really appreciate all your help.

And regarding the comments from NeoPa, thanks and yes I do understand Normalisation and Table Structures and agree that this goes against the grain, but the EmployeeTbl has less than 20 records - so I stand by my comment that space is not an issue in this particular Db.

Cheers and thanks ADezii once again.

[edsuk]

hi ADezii

I have made one very insignifficant mod to the populateCalenda r sub.

Which you may like or not to include in the future.

the mod is at line 74

Currently:

If bytBlankBlocksAfter > 6 And bytBlockCounter > 35 Then
   ctlDayBlock.Visible = False
End If

Amended To:

If bytBlankBlocksAfter > 6 And bytBlockCounter > 35 Then
   ctlDayBlock.Visible = False
Else
   ctlDayBlock.Visible = True
End If

If you scroll through the months, say to May 2010, we get an incomplete row at the bottom as only the first two textboxes are visible. This mod just makes the whole of the bottom row visible to complete the grid.

I did say it was insignifficant.

this sample DB is great - thanks.

[NeoPa]

As an alternative (same effect - different code) you could say :

ctlDayBlock.Visible = ((bytBlankBlocksAfter < 7) Or (bytBlockCounter < 36))

[ADezii]

I must say that it does make the Calendar uniform and symmetrical, thank you.

[ADezii]

You are quite welcome. I must state again that I am not the original creator of the Calendar Database. The original Author is a friend and ex co-worker who created this basically as a Platoon Scheduler and simple Events Posting utility. With his explicit permission, I've simply adapted it many times over the years for specific purposes and distributed it as freeware to the GP.

[NeoPa]

Well then - thanks certainly go to your generous ex- co-worker.

We still appreciate the time, effort and understanding you put in on behalf of numerous members to provide this and make certain changes so that they can all use it easily. That is no mean offering my friend, and I'm pretty sure most of those you've helped very much appreciate your part in all this.

[ADezii]

Hello again, edsuk:

1. BTW, for my own curiosity, did you have to swap Lines 21 and 26 as I indicated to in Post #228?
2. There is a Logic Bug that you should be aware of and correct. I discovered the Bug awhile ago, and I actually corrected it minutes ago (I know, I know!). Should you ever set a Reference to the ADO Object Library as well as DAO, and place it at a higher Priority Level within the References, the code will crash for obvious reasons (DAO References for db and rstEvents were not Explicitly Declared.
3. The following Line of Variable Declarations in the PopulateCalenda r() Routine should be changed. Original Declarations are:
   

   Dim astrCalendarBlocks(1 To 42) As String, db As Database, rstEvents As Recordset

   but they should be:
   

   Dim astrCalendarBlocks(1 To 42) As String, db As DAO.Database, rstEvents As DAO.Recordset

4. Because of the Logic used implementing this Database, the constant Deleting and Appending of Records to an Intermediate Table, frequent Compacting of the Database should be performed on a regular basis.
5. When I get a chance, I will Post the Calendar Database with the Logic Bug corrected, edsuk's significant Update, and some visual enhancements to frmCalendar. When this happens, prior Attachments will be removed.

[edsuk]

hi ADezii

1) Yes I did have to modify this line to the UK date format. Thanks for the heads up on this - would have taken me ages to figure out otherwise.
2) I do have a reference to both DAO and ADO in my Db with DAO being higher, good to know that you spotted it for for future reference.
3) OK
4) Yes, always good to perform this action periodically.
5) Significant update - I think not LOL

Again thank you and thanks to your friend/ex co-worker..

[ADezii]

Well then - thanks certainly go to your generous ex- co-worker.

We still appreciate the time, effort and understanding you put in on behalf of numerous members to provide this and make certain changes so that they can all use it easily. That is no mean offering my friend, and I'm pretty sure most of those you've helped very much appreciate your part in all this.

Thanks for the kind words, NeoPa.

[ADezii]

hi ADezii

1) Yes I did have to modify this line to the UK date format. Thanks for the heads up on this - would have taken me ages to figure out otherwise.
2) I do have a reference to both DAO and ADO in my Db with DAO being higher, good to know that you spotted it for for future reference.
3) OK
4) Yes, always good to perform this action periodically.
5) Significant update - I think not LOL

Again thank you and thanks to your friend/ex co-worker..

Yes I did have to modify this line to the UK date format. Thanks for the heads up on this - would have taken me ages to figure out otherwise.

Our own beloved msquared spotted this Bug awhile ago when I was at my wits end trying to determine where the problem was. Simple no peripheral vision, I guess. Thanks again Mary.

[ADezii]

Calendar for Date Range

Here is the latest Calendar Demo, with all Revisions and Enhancements, for a Date Range.

[scootaman]

How do I get this to work in my 2007 database?

Your calendar form looks great and is what I have been searching for. However, I don't know how to impement it in my database. Do I need to import all the queries in addition to the mods and form? What lines need to be changed to work with my table?

Table:
Training_Events

Fields:
ID
Title
Start Date
End Date
Start Time
End Time
Location
Description
Trainer
Vendor
Attachements


I am building a database to keep track of maditory State and Federal training for employees. This form would be a great way to view my scheduled training events and I wouldn't have to do double entry on my Groupwise calendar.

Any help is greatly appreciated. I am not very good at coding.
Thanks

[ADezii]

1. If you can, Upload a Database consisting of only the Table Training_Events and approximately 12 Records.
2. Let me know what Field(s) you wish to display in the Calendar for any given day.
3. From this I'll construct a simple Demo from which you can get started.
4. With limited coding experience, this would probably be your only option.