Calendar Form showing wrong year Access 07 (1 Viewer)

[coolcatkelso]

Hiya

I've got a calendar form, which you can select the Month & Year from an unbound combo box.

Problem I get is this - This is Feb 09, 1st of feb started on a Sunday

My calendar shows the following - Feb 09 FRIDAY is the 1st?

The code is

Option Compare Database
Option Explicit
Dim objCurrentDate As New objDateInfo
Private Sub PopulateYearListBox()
Dim intYear As Integer
Dim intYearCounter As Integer
Dim strRowSource As String
intYear = objCurrentDate.Year
Me.cboYear = intYear
For intYearCounter = (intYear - 1) To (intYear + 1) 'a 24 year range
strRowSource = strRowSource & LTrim(Str(intYearCounter)) & ";"
Next intYearCounter
strRowSource = strRowSource & LTrim(Str(intYearCounter)) 'the 25th year, no semi-colon
Me.cboYear.RowSource = strRowSource

End Sub
Private Sub OpenEventForm(ctlDayBlock As Control)
DoCmd.OpenForm "frmEvents", , , , , , ctlDayBlock.Tag
End Sub
Private Sub cboMonth_AfterUpdate()
On Error GoTo Err_cboMonth_AfterUpdate
Select Case Me![cboMonth]
Case "January"
objCurrentDate.Month = 1
Case "February"
objCurrentDate.Month = 2
Case "March"
objCurrentDate.Month = 3
Case "April"
objCurrentDate.Month = 4
Case "May"
objCurrentDate.Month = 5
Case "June"
objCurrentDate.Month = 6
Case "July"
objCurrentDate.Month = 7
Case "August"
objCurrentDate.Month = 8
Case "September"
objCurrentDate.Month = 9
Case "October"
objCurrentDate.Month = 10
Case "November"
objCurrentDate.Month = 11
Case "December"
objCurrentDate.Month = 12
Case Else
End Select
PopulateCalendar
Exit_cboMonth_AfterUpdate:
Exit Sub
Err_cboMonth_AfterUpdate:
MsgBox Err.Description, vbExclamation, "Error in cboMonth_AfterUpdate()"
Resume Exit_cboMonth_AfterUpdate
End Sub
Private Sub cboMonth_KeyDown(KeyCode As Integer, Shift As Integer)
KeyCode = 0
'added to stop vba crash on null
End Sub
Private Sub cboYear_AfterUpdate()
objCurrentDate.Year = Me![cboYear]
PopulateCalendar

End Sub
Private Sub cboYear_KeyDown(KeyCode As Integer, Shift As Integer)
KeyCode = 0
'added to stop vba crash on null
End Sub
Private Sub cmdNextMonth_Click()
Me![cboYear] = Null
Me![cboMonth] = Null
objCurrentDate.Month = objCurrentDate.Month + 1
If objCurrentDate.Month = 13 Then
objCurrentDate.Month = 1
objCurrentDate.Year = objCurrentDate.Year + 1
End If
PopulateCalendar
End Sub
Private Sub cmdPreviousMonth_Click()
Me![cboYear] = Null
Me![cboMonth] = Null
objCurrentDate.Month = objCurrentDate.Month - 1
If objCurrentDate.Month = 0 Then
objCurrentDate.Month = 12
objCurrentDate.Year = objCurrentDate.Year - 1
End If
PopulateCalendar
End Sub


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 intMonth As Integer, intYear As Integer, 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
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)
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 Qry_CalData.DateA,Qry_CalData.LastName,Qry_CalData.TimeFrom "
strSQL = strSQL & "FROM Qry_CalData "
strSQL = strSQL & "WHERE (Qry_CalData.DateA) Between " & lngFirstOfMonth & " And " & lngLastOfMonth & " ORDER BY "
strSQL = strSQL & "Qry_CalData.DateA;"
Set rstEvents = db.OpenRecordset(strSQL)
Do While Not rstEvents.EOF
strEvent = rstEvents!LastName & " - " & rstEvents!TimeFrom
bytEventDayOfMonth = (rstEvents!DateA - 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(14)
ctlDayBlock.ForeColor = QBColor(8)
Set ctlSystemDateBlock = ctlDayBlock
blnSystemDateIsShown = True
Else
ctlDayBlock.BackColor = 16777215
ctlDayBlock.ForeColor = 8388608
End If
ctlDayBlock.Visible = True
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
Exit_PopulateCalendar:
Exit Sub
Err_PopulateCalendar:
MsgBox Err.Description, vbExclamation, "Error inPopulateCalendar()"
Resume Exit_PopulateCalendar
End Sub

Private Sub ReferenceABlock(ctlDayBlock As Control, bytIndex As Byte)
Set ctlDayBlock = Choose(bytIndex, _
txtDayBlock01, txtDayBlock02, txtDayBlock03, txtDayBlock04, txtDayBlock05, _
txtDayBlock06, txtDayBlock07, txtDayBlock08, txtDayBlock09, txtDayBlock10, _
txtDayBlock11, txtDayBlock12, txtDayBlock13, txtDayBlock14, txtDayBlock15, _
txtDayBlock16, txtDayBlock17, txtDayBlock18, txtDayBlock19, txtDayBlock20, _
txtDayBlock21, txtDayBlock22, txtDayBlock23, txtDayBlock24, txtDayBlock25, _
txtDayBlock26, txtDayBlock27, txtDayBlock28, txtDayBlock29, txtDayBlock30, _
txtDayBlock31, txtDayBlock32, txtDayBlock33, txtDayBlock34, txtDayBlock35, _
txtDayBlock36, txtDayBlock37, txtDayBlock38, txtDayBlock39, txtDayBlock40, _
txtDayBlock41, txtDayBlock42)
End Sub
Private Function MonthAndYear(intMonth As Integer, intYear As Integer) As String
Dim strMonth As String
strMonth = Choose(intMonth, _
"January", "February", "March", "April", "May", "June", _
"July", "August", "September", "October", "November", "December")
MonthAndYear = strMonth & " " & intYear
End Function
Private Sub Form_Activate()
PopulateCalendar
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim dtmTodaysDate
dtmTodaysDate = Now
objCurrentDate.Month = Month(dtmTodaysDate)
objCurrentDate.Year = Year(dtmTodaysDate)
End Sub

Private Sub txtDayBlock01_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock02_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock03_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock04_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock05_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock06_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock07_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock08_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock09_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock10_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock11_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock12_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock13_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock14_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock15_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock16_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock17_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock18_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock19_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock20_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock21_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock22_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock23_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock24_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock25_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock26_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock27_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock28_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock29_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock30_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock31_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock32_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock33_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock34_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock35_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock36_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock37_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock38_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock39_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock40_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock41_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub txtDayBlock42_GotFocus()
PopulateEventsList Me.ActiveControl
End Sub
Private Sub PopulateEventsList(ctlDayBlock As Control)
On Error GoTo Err_PopulateEventsList
Dim strSQL2 As String
strSQL2 = "SELECT Qry_CalData.DateA,Qry_CalData.LastName,Qry_CalData.TimeFrom "
strSQL2 = strSQL2 & "FROM Qry_CalData "
strSQL2 = strSQL2 & "WHERE (((Qry_CalData.DateA)=" & ctlDayBlock.Tag & "));"

lstEvents.RowSource = strSQL2
lblEventsOnDate.Caption = Format(ctlDayBlock.Tag, "dd-mm-yyyy")
lstEvents.Visible = True
lblEventsOnDate.Visible = True

Exit_PopulateEventsList:
Exit Sub

Err_PopulateEventsList:
MsgBox Err.Description, vbExclamation, "Error in PopulateEventsList()"
Resume Exit_PopulateEventsList
End Sub
Private Sub cmdCloseForm_Click()
On Error GoTo Err_cmdCloseForm_Click
DoCmd.Close
Exit_cmdCloseForm_Click:
Exit Sub
Err_cmdCloseForm_Click:
MsgBox Err.Description
Resume Exit_cmdCloseForm_Click

End Sub
________
Prilosec Lawsuit

 

[raskew]

Hi -

Where's that code coming from? Can you post a link to it.

Bob

 

[coolcatkelso]

Hiya

The code is coming from the main calendar form

I've attached a brief copy of the DB, the main form will popup, just ignore that one and click the button for Calendar, you'll see the problem from there

Cheers
________
Bondage Porn

 

[raskew]

Hi -

May I suggest that you take a look at Allen Browne's popup calendar here: http://allenbrowne.com/ser-51.html.

Looking at your current code, I'd have to say that it clunks. Allen's code is infinitely more consise.

HTH - Bob

 

[coolcatkelso]

Hi bob

Thanks for the reply and the link

I had a look but the popup calendar is completely different. The one I need has to display the appointments for that day. I could look at the way the coding works for this popup one and try and work it in to the one I want, but I'm not good with code, I wouldn't even say I was 10% up on VBA

Anyhelp would be great tho lol
________
Singapore cooking

 

[coolcatkelso]

Woooohooooo

I got it working

The problem was lying is this section

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)

If you change the last part to this -

strFirstOfMonth = "1/" & Str(intMonth) & Str(intYear)

The calendar displays the right days on the right date

The original I think is worked out to Non-EU countries

Thanks to everyone who tried to help

Anyone looking for a good Calendar and Appointment maker, then they should use this one
________
Vaporizers""