I have an example of a calendar that does just that. However, this site has a rule that I cannot post my email address so that I can get your request and send you my example. I've been thrown off before. I'll give you another example that maybe you can play with. First create a 2" form. On this form create label boxes. Starting at the top, labels with capitons <<, then <, then >, and >>. Next row has S, M, T, W, T, F, S. Then 48 labels denoted by lab1 to lab47 (caption 0 for all). Finally a row with two labels, one that says Today and another that says Cancel. Call the form frmCalendar. Copy the following code (here you can see what to call your labels).
Option Compare Database
Dim datArg As Date ' Default date passed to frmCalendar
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
' Allow for paging up and down through months
Select Case KeyCode
Case 33 ' Page up
Call labMthSub_Click
Case 34 ' Page down
Call labMthAdd_Click
End Select
End Sub
Private Sub Form_Load()
If IsDate(ctlIn) Then ' If control already contains a date...
datArg = ctlIn ' ... use that to start
Else
datArg = Date ' ...otherwise start at today's date
End If
labDat.Caption = Format(datArg, "mmmm yyyy") ' Set frmCalendar's MMMM YYYY banner
fctnPopulate ' Function to set and format the calendar grid
End Sub
Private Function fctnDate_Click(ctl As Control)
' Called by clicking any date on the calendar grid
Dim datOut As Date ' Date variable to be retained after frmCalendar is closed
If ctl.ForeColor = 0 Then ' In the currently displayed month, i.e. date not greyed out
datOut = CDate(ctl.Caption & " " & labDat.Caption) ' Set datOut
Else
If CInt(Mid$(ctl.Name, 4)) < 8 Then ' Tail-end of the previous month
datOut = CDate(ctl.Caption & " " & Format(CDate(Format(labDat.Caption, "dd-mmm-yyyy")) - 1, "mmmm yyyy")) ' Set datOut
Else ' Start of the next month
datOut = CDate(ctl.Caption & " " & Format(CDate(Format(labDat.Caption, "dd-mmm-yyyy")) + 31, "mmmm yyyy")) ' Set datOut
End If
End If
DoCmd.Close acForm, "frmCalendar", acSaveNo ' Close frmCalendar first, as it's modal
ctlIn = datOut
End Function
Private Function fctnPopulate()
' Populate and format the calendar labels grid
Dim datIn As Date ' Date variable to be set as the first day of the displayed month
Dim bytLab As Byte ' Byte variable to be set as the day of the week the first of the month is on
Dim ctl As Control ' Control object allows calendar grid controls to be looped through
Dim strLab As String ' String variable used to isolate the numeric portion of a calendar grid control's name
Dim datOut As Date ' Date variable set and written out to the calendar grid controls
datIn = Format(labDat.Caption, "dd-mmm-yyyy") ' Set to the first of the displayed month
bytLab = Weekday(datIn, vbSunday) ' Determine which day of the week the first of the month is on
For Each ctl In Me.Controls ' Loop through all the controls on the form
If ctl.Tag = 1 Then ' All 42 of the calendar grid date labels have a Tag value of 1
strLab = Mid$(ctl.Name, 4) ' Works out with date label is being used, i.e. control lab35 returns strLab="35"
datOut = datIn + (CInt(strLab) - bytLab) ' Use datIn and offset from first day of the month control to set value of datOut
ctl.Caption = Format(datOut, "dd") ' Set the control's caption to the date portion of datOut
ctl.BorderStyle = -1 * (datOut = Date) 'If today's date then border in red
ctl.BackColor = 16777215 + (4144959 * (datOut = datArg)) ' Background is grey if default date, otherwise white
If Left$(ctl.Caption, 1) = "0" Then ctl.Caption = Mid$(ctl.Caption, 2) ' Remove leading zeros, so 01 becomes 1
If Format(datIn, "mm") = Format(datOut, "mm") Then ' If control's date value is in the displayed month
ctl.ForeColor = 0 ' Text is black
Else ' Tail-end of previous month or beginning of next
ctl.ForeColor = 8421504 ' Text is dark grey
End If
End If
Next ctl ' Do the loop
End Function
Private Sub labCancel_Click()
DoCmd.Close ' Close frmCalendar
End Sub
Private Sub labMthAdd_Click()
labDat.Caption = Format(CDate(Format(labDat.Caption, "dd-mmm-yyyy")) + 31, "mmmm yyyy") ' Re-banner the form with next month
fctnPopulate ' Function to set and format the calendar grid
End Sub
Private Sub labMthSub_Click()
labDat.Caption = Format(CDate(Format(labDat.Caption, "dd-mmm-yyyy")) - 1, "mmmm yyyy") ' Re-banner the form with previous month
fctnPopulate ' Function to set and format the calendar grid
End Sub
Private Sub labToday_Click()
labDat.Caption = Format(Date, "mmmm yyyy") ' Re-banner the form with the current month
fctnPopulate ' Function to set and format the calendar grid
End Sub
Private Sub labYrAdd_Click()
labDat.Caption = Format(CDate(Format(labDat.Caption, "dd-mmm-yyyy")) + 366, "mmmm yyyy") ' Re-banner the form with this month next year
fctnPopulate ' Function to set and format the calendar grid
End Sub
Private Sub labYrSub_Click()
labDat.Caption = Format(CDate(Format(labDat.Caption, "dd-mmm-yyyy")) - 365, "mmmm yyyy") ' Re-banner the form with this month last year
fctnPopulate ' Function to set and format the calendar grid
End Sub
Then on a control that needs a date, place the following code: (create the global variable ctlIn)
Private Sub DateOfNotice_DblClick(Cancel As Integer)
Set ctlIn = Me.ActiveControl ' Get global variable to active control
DoCmd.OpenForm "frmCalendar"
End Sub
In the function fctnPopulate, you can place code to read dates off your table and then change those dates background colors.
Hopes this helps. It would be easier to send you the examples, but we're not allow to put email addresses in a post.
