Colour specific dates on the Calender Control 9.0

[spgreen]

Hi All,
I want to use the calender control to show up which days a specified clinic is running. So when a user brings up the month of September each of the days that the clinic occurs (stored on a table) shows up as a different colour to the standard colours. Has anyone done this, is is possible

Simon

 

[spgreen]

Anybody got any idea if this is possible. I've been tearing my hair out all day to try and work out how to do this

help please

Simon

 

[spgreen]

i don't like bumping but has anyone any idea of how to do this. it really would make life a lot easier

 

[fneily]

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.