G
Guest
Howdy. I'd like to modify Allen Browne's popup calendar form to
automatically set the highlighted date and close the form when you hit enter,
rather than having to press the 'OK' button. Currently, pressing 'Enter'
gets you to a different month. Here's the code, for reference:
'Author: Allen Browne. (e-mail address removed)
'You may use this example for private, business, or educational purposes,
with acknowledgement.
'However, you may not publish it without the express, written permission of
the author.
'You also need this code in a standard module:
'---------------------standard module code begins-------------------------
'Public gtxtCalTarget As TextBox 'Text box to return the date from the
calendar to.
'Public Function CalendarFor(txt As TextBox, Optional strTitle As String)
'On Error GoTo Err_Handler
' 'Purpose: Open the calendar form, identifying the text box to return
the date to.
' 'Arguments: txt = the text box to return the date to.
' ' strTitle = the caption for the calendar form (passed in
OpenArgs).
'
' Set gtxtCalTarget = txt
' DoCmd.OpenForm "frmCalendar", windowmode:=acDialog, OpenArgs:=strTitle
'
'Exit_Handler:
' Exit Function
'
'Err_Handler:
' MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
"CalendarFor()"
' Resume Exit_Handler
'End Function
'---------------------standard module code ends-------------------------
Option Compare Database
Option Explicit
Private Const lngcFirstDayOfWeek = vbSunday 'Weekday of the first column in
the calendar.
Private Const lngcWeekendForeColor = 192& 'RGB value for Saturdays and
Sundays.
Private Const conMod = "frmCalendar" 'Name of this module (for error
handler.)
Private Sub cmdCancel_Click()
On Error GoTo Err_Handler
'Purpose: Close without transferring date back to calling text box.
DoCmd.Close acForm, Me.Name, acSaveNo
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".cmdCancel_Click"
Resume Exit_Handler
End Sub
Private Sub cmdMonthDown_Click()
Call SetDate("M", -1)
End Sub
Private Sub cmdMonthUp_Click()
Call SetDate("M", 1)
End Sub
Private Sub cmdOk_Click()
On Error Resume Next
'Purpose: Transfer the result back to the calling text box (if there
is one), and close.
If gtxtCalTarget = Me.txtDate Then
'do nothing
Else
gtxtCalTarget = Me.txtDate
End If
gtxtCalTarget.SetFocus
DoCmd.Close acForm, Me.Name, acSaveNo
End Sub
Private Sub cmdYearDown_Click()
Call SetDate("YYYY", -1)
End Sub
Private Sub cmdYearUp_Click()
Call SetDate("YYYY", 1)
End Sub
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_Err
'Initialize to the existing date, or today if null.
If IsDate(gtxtCalTarget) Then
Me.txtDate = gtxtCalTarget.Value
Else
Me.txtDate = Date
End If
'Set the title
If Len(Me.OpenArgs) > 0& Then
Me.Caption = Me.OpenArgs
End If
'Set up the calendar for this month.
Call ShowCal
Form_Open_Exit:
Exit Sub
Form_Open_Err:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbCritical,
conMod & ".frmCalendar.Form_Open"
Resume Form_Open_Exit
End Sub
Private Function SetSelected(ctlName As String)
On Error GoTo Err_Handler
Me.txtDate = DateSerial(Year(txtDate), Month(txtDate),
CLng(Me(ctlName).Caption))
Call ShowHighligher(ctlName)
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".SetSelected"
Resume Exit_Handler
End Function
Private Function SelectDate(ctlName As String)
Call SetSelected(ctlName)
Call cmdOk_Click
End Function
Private Function SetDate(Unit As String, Optional intStep As Integer = 1)
On Error GoTo Err_Handler
Me.txtDate = DateAdd(Unit, intStep, Me.txtDate)
Call ShowCal
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".SetDate"
Resume Exit_Handler
End Function
Private Function ShowCal() As Boolean
On Error GoTo Err_Handler
'Purpose:
Dim dtStartDate As Date 'First of month
Dim iDays As Integer 'Days in month
Dim iOffset As Integer 'Offset to first label for month.
Dim i As Integer 'Loop controller.
Dim j As Integer 'Inner loop controller.
Dim iDay As Integer 'Day under consideration.
Dim bshow As Boolean 'Flag: show label
dtStartDate = Me.txtDate - Day(Me.txtDate) + 1 'First of month
iDays = Day(DateAdd("m", 1, dtStartDate) - 1) 'Days in month.
iOffset = Weekday(dtStartDate, lngcFirstDayOfWeek) - 2 'Offset to first
label for month.
'Show the days on the grid.
For i = 0 To 41
With Me("lblDay" & Format(i, "00"))
iDay = i - iOffset
bshow = ((iDay > 0) And (iDay <= iDays))
If .Visible <> bshow Then
.Visible = bshow
End If
If (bshow) And (.Caption <> iDay) Then
.Caption = iDay
End If
End With
Next
'Set the labels for the weekday names, and the colors for weekends.
For i = 0 To 6
iDay = ((lngcFirstDayOfWeek + i - 1) Mod 7) + 1
With Me("lblCol" & i)
.Caption = Left(Format(iDay, "ddd"), 2)
If iDay = vbSunday Or iDay = vbSaturday Then
Me("lblCol" & i).ForeColor = lngcWeekendForeColor
For j = 0 To 5
Me("lblDay" & Format(7 * j + i, "00")).ForeColor =
lngcWeekendForeColor
Next
End If
End With
Next
'Place the highligher circle on the grid for the selected day.
Call ShowHighligher("lblDay" & Format(Day(Me.txtDate) + iOffset, "00"))
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".ShowCal"
Resume Exit_Handler
End Function
Private Function ShowHighligher(ctlName As String)
On Error GoTo Err_Handler
Const lngcVOffset As Long = -83
With Me(ctlName)
Me.lblHighlight.Left = .Left
Me.lblHighlight.Top = .Top + lngcVOffset
End With
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".ShowHighligher"
Resume Exit_Handler
End Function
Private Sub lblToday_Click()
Me.txtDate = Date
Call ShowCal
End Sub
automatically set the highlighted date and close the form when you hit enter,
rather than having to press the 'OK' button. Currently, pressing 'Enter'
gets you to a different month. Here's the code, for reference:
'Author: Allen Browne. (e-mail address removed)
'You may use this example for private, business, or educational purposes,
with acknowledgement.
'However, you may not publish it without the express, written permission of
the author.
'You also need this code in a standard module:
'---------------------standard module code begins-------------------------
'Public gtxtCalTarget As TextBox 'Text box to return the date from the
calendar to.
'Public Function CalendarFor(txt As TextBox, Optional strTitle As String)
'On Error GoTo Err_Handler
' 'Purpose: Open the calendar form, identifying the text box to return
the date to.
' 'Arguments: txt = the text box to return the date to.
' ' strTitle = the caption for the calendar form (passed in
OpenArgs).
'
' Set gtxtCalTarget = txt
' DoCmd.OpenForm "frmCalendar", windowmode:=acDialog, OpenArgs:=strTitle
'
'Exit_Handler:
' Exit Function
'
'Err_Handler:
' MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
"CalendarFor()"
' Resume Exit_Handler
'End Function
'---------------------standard module code ends-------------------------
Option Compare Database
Option Explicit
Private Const lngcFirstDayOfWeek = vbSunday 'Weekday of the first column in
the calendar.
Private Const lngcWeekendForeColor = 192& 'RGB value for Saturdays and
Sundays.
Private Const conMod = "frmCalendar" 'Name of this module (for error
handler.)
Private Sub cmdCancel_Click()
On Error GoTo Err_Handler
'Purpose: Close without transferring date back to calling text box.
DoCmd.Close acForm, Me.Name, acSaveNo
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".cmdCancel_Click"
Resume Exit_Handler
End Sub
Private Sub cmdMonthDown_Click()
Call SetDate("M", -1)
End Sub
Private Sub cmdMonthUp_Click()
Call SetDate("M", 1)
End Sub
Private Sub cmdOk_Click()
On Error Resume Next
'Purpose: Transfer the result back to the calling text box (if there
is one), and close.
If gtxtCalTarget = Me.txtDate Then
'do nothing
Else
gtxtCalTarget = Me.txtDate
End If
gtxtCalTarget.SetFocus
DoCmd.Close acForm, Me.Name, acSaveNo
End Sub
Private Sub cmdYearDown_Click()
Call SetDate("YYYY", -1)
End Sub
Private Sub cmdYearUp_Click()
Call SetDate("YYYY", 1)
End Sub
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_Err
'Initialize to the existing date, or today if null.
If IsDate(gtxtCalTarget) Then
Me.txtDate = gtxtCalTarget.Value
Else
Me.txtDate = Date
End If
'Set the title
If Len(Me.OpenArgs) > 0& Then
Me.Caption = Me.OpenArgs
End If
'Set up the calendar for this month.
Call ShowCal
Form_Open_Exit:
Exit Sub
Form_Open_Err:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbCritical,
conMod & ".frmCalendar.Form_Open"
Resume Form_Open_Exit
End Sub
Private Function SetSelected(ctlName As String)
On Error GoTo Err_Handler
Me.txtDate = DateSerial(Year(txtDate), Month(txtDate),
CLng(Me(ctlName).Caption))
Call ShowHighligher(ctlName)
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".SetSelected"
Resume Exit_Handler
End Function
Private Function SelectDate(ctlName As String)
Call SetSelected(ctlName)
Call cmdOk_Click
End Function
Private Function SetDate(Unit As String, Optional intStep As Integer = 1)
On Error GoTo Err_Handler
Me.txtDate = DateAdd(Unit, intStep, Me.txtDate)
Call ShowCal
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".SetDate"
Resume Exit_Handler
End Function
Private Function ShowCal() As Boolean
On Error GoTo Err_Handler
'Purpose:
Dim dtStartDate As Date 'First of month
Dim iDays As Integer 'Days in month
Dim iOffset As Integer 'Offset to first label for month.
Dim i As Integer 'Loop controller.
Dim j As Integer 'Inner loop controller.
Dim iDay As Integer 'Day under consideration.
Dim bshow As Boolean 'Flag: show label
dtStartDate = Me.txtDate - Day(Me.txtDate) + 1 'First of month
iDays = Day(DateAdd("m", 1, dtStartDate) - 1) 'Days in month.
iOffset = Weekday(dtStartDate, lngcFirstDayOfWeek) - 2 'Offset to first
label for month.
'Show the days on the grid.
For i = 0 To 41
With Me("lblDay" & Format(i, "00"))
iDay = i - iOffset
bshow = ((iDay > 0) And (iDay <= iDays))
If .Visible <> bshow Then
.Visible = bshow
End If
If (bshow) And (.Caption <> iDay) Then
.Caption = iDay
End If
End With
Next
'Set the labels for the weekday names, and the colors for weekends.
For i = 0 To 6
iDay = ((lngcFirstDayOfWeek + i - 1) Mod 7) + 1
With Me("lblCol" & i)
.Caption = Left(Format(iDay, "ddd"), 2)
If iDay = vbSunday Or iDay = vbSaturday Then
Me("lblCol" & i).ForeColor = lngcWeekendForeColor
For j = 0 To 5
Me("lblDay" & Format(7 * j + i, "00")).ForeColor =
lngcWeekendForeColor
Next
End If
End With
Next
'Place the highligher circle on the grid for the selected day.
Call ShowHighligher("lblDay" & Format(Day(Me.txtDate) + iOffset, "00"))
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".ShowCal"
Resume Exit_Handler
End Function
Private Function ShowHighligher(ctlName As String)
On Error GoTo Err_Handler
Const lngcVOffset As Long = -83
With Me(ctlName)
Me.lblHighlight.Left = .Left
Me.lblHighlight.Top = .Top + lngcVOffset
End With
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation,
conMod & ".ShowHighligher"
Resume Exit_Handler
End Function
Private Sub lblToday_Click()
Me.txtDate = Date
Call ShowCal
End Sub