change colour of text if a certain field is "cancelled"

[sheepchild]

This is a ADezii's Db


All i'm trying trying to do is to get the text to change the text colour depending on the status of the which comes from the booking table.

tbl_bookings.status ("confirmed", "cancelled", "provisional")

below is the block which seams to change the colours of the text in the boxes.

        If lngBlockDate = lngSystemDate Then
          ctlDayBlock.BackColor = QBColor(13)
          ctlDayBlock.ForeColor = QBColor(15)
          Set ctlSystemDateBlock = ctlDayBlock
          blnSystemDateIsShown = True
        Else
          ctlDayBlock.BackColor = 16777215      'Background Main cell colour
          ctlDayBlock.ForeColor = 8388608       ' txt colour
        End If
 
          ctlDayBlock.Visible = True
          ctlDayBlock.Enabled = True
          ctlDayBlock.Tag = lngBlockDate
 
 
 

so guessing i need to change add in an extra if statement,

If status = "cancled" Then

as well as alter the SQL to pull through the "status" section?

strSQL = "SELECT * From tbl_Bookings "
strSQL = strSQL & "WHERE tbl_Bookings.[MeetingDate] Between " & lngFirstOfMonth & " And " & lngLastOfMonth & _
                  " ORDER BY tbl_Bookings.[EventID];"
 

and also add in a variable at the top???

any help???? i'm a little lost.

[jforbes]

Would you post the entire method?

I don't know that database and it's a little hard to be 100% sure with only the snippets that have been posted.

[sheepchild]

below is the block which i think populates the blocks which are on the main calendar form in a txt box. (for example txtDayBlock01). so this is why im not sure if what to do as im not sure if it is possible to have multiple formats within one textbox?

 
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
Dim blnRetVal
 
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 = "1/" & Str(intMonth) & Str(intYear)
bytFirstWeekdayOfMonth = Weekday(strFirstOfMonth, vbMonday)  'add , vbmonday tostart monday
'bytFirstWeekdayOfMonth = Weekday(strFirstOfMonth)  'starts sunday
lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
lngLastOfMonth = lngFirstOfNextMonth - 1
lngLastOfPreviousMonth = lngFirstOfMonth - 1 'highlight of current day
bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
 
 
Set db = CurrentDb
 
strSQL = "SELECT * From tbl_Bookings "
strSQL = strSQL & "WHERE tbl_Bookings.[MeetingDate] Between " & lngFirstOfMonth & " And " & lngLastOfMonth & _
                  " ORDER BY tbl_Bookings.[EventID];"
 
Set rstEvents = db.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)    'Added 4/16/2008
 
Do While Not rstEvents.EOF
  strEvent = rstEvents![EventTitle] ' & vbCrLf & rstEvents![StartTime] & " - " & rstEvents![EndTime] 'have date and time
  bytEventDayOfMonth = (rstEvents!MeetingDate - 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      'Background Main cell colour
          ctlDayBlock.ForeColor = 8388608       ' txt colour
        End If
 
'        If "tbl_bookings.[Status]" = "Cancelled" Then
'            ctlDayBlock.ForeColor = 12632256
'        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    '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
 
 

let me know if you want me to post the db.

[jforbes]

This would be my best guess:

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 astrCalendarBlocksStatus(1 To 42) As String
    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
    Dim blnRetVal
 
    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 = "1/" & Str(intMonth) & Str(intYear)
    bytFirstWeekdayOfMonth = Weekday(strFirstOfMonth, vbMonday)  'add , vbmonday tostart monday
    'bytFirstWeekdayOfMonth = Weekday(strFirstOfMonth)  'starts sunday
    lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
    lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
    lngLastOfMonth = lngFirstOfNextMonth - 1
    lngLastOfPreviousMonth = lngFirstOfMonth - 1 'highlight of current day
    bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
    bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
    bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
 
 
    Set db = CurrentDb
 
    strSQL = "SELECT * From tbl_Bookings "
    strSQL = strSQL & "WHERE tbl_Bookings.[MeetingDate] Between " & lngFirstOfMonth & " And " & lngLastOfMonth & _
                      " ORDER BY tbl_Bookings.[EventID];"
 
    Set rstEvents = db.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)    'Added 4/16/2008
 
    Do While Not rstEvents.EOF
      strEvent = rstEvents![EventTitle] ' & vbCrLf & rstEvents![StartTime] & " - " & rstEvents![EndTime] 'have date and time
      bytEventDayOfMonth = (rstEvents!MeetingDate - lngLastOfPreviousMonth)
      bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
        If astrCalendarBlocks(bytBlockCounter) <> "" Then
          astrCalendarBlocks(bytBlockCounter) = _
          astrCalendarBlocks(bytBlockCounter) & vbNewLine & strEvent
        Else
          astrCalendarBlocks(bytBlockCounter) = strEvent
        End If
         astrCalendarBlocksStatus(bytBlockCounter) = Nz(rstEvents![Status], "")
        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.ForeColor = 8388608       ' txt colour
               If astrCalendarBlocksStatus(bytBlockCounter) = "Cancelled" Then
                 ctlDayBlock.BackColor = 12632256      'Background if Cancelled
               Else
                 ctlDayBlock.BackColor = 16777215      'Background Main cell colour
               End If
            End If
...

I didn't see any place that the status was being read in from the Table, so I added the array astrCalendarBlocksStatus to hold them. The array is then used again later when the Background Color is being set. This is just one way of doing it. Another way is to change the array to be that of long and determine the color while the records are being looped.

[sheepchild]

coming up with error of cant assign to array and stopping code at

astrCalendarBlocksStatus = Nz(rstEvents![Status], "")
 
 

Status is being taken from each record, as this can change, and there can be multiple events on one day.

status would be from tbl_bookings.staus ??

[jforbes]

There was a typo for line 53 that has been fixed, it was this:

astrCalendarBlocksStatus = Nz(rstEvents![Status], "")

it should be this:

astrCalendarBlocksStatus(bytBlockCounter) = Nz(rstEvents![Status], "")

I have no way to be sure of where the Status is coming from. I don't have a copy of that database and I'm going off information that you are providing.


If you can truly have multiple events on the same day, then how would you like to determine the Background Color? As it stands, the last Event that is encountered in rstEvents for a given day will be the one to determine the Background Color.

Another option, which would be somewhat tricky, is to use a TextBox with .TextFormat of "Rich Text" and set a BackgroundColor for each individual event per day. On the plus side the Rich Text approach would eliminate the need for the new Array and allow the BackgroundColor to be defined in astrCalendarBlocks.

[sheepchild]

now coming up with a compile error of no 'end select'

i put one in at the bottom and compile error for without next.


i understand sorry, attached now is a lite version of the database, Satus is coming from the tblevents which is where the date and start times etc.. come from.

i was thinking more of changing the text for that event rather than the whole block.

thought changing the block colour for certain days such as bank holidays or weekend etc.. was something i was also thinking of.

I happy to modify when the base of the idea is correct, just have no idea where to start with it all or the best way of doing it. so all help is greatly appreciated.

[jforbes]

This is what I came up with, it allows for each appointment to be color coded both the Foreground and Background. I don't know if you need all that flexibility, but it was only a couple lines more of code.

To get this to work, you will need to change the .TextFormat property to "Rich Text" for all 42 TextBoxes. Just select them all and change the property once.

The following code will need to be placed at the Top of the Code for the fdlgEventDetails(frmCalendar):

Private Const nAppointmentTemplate = "<div><font color={2} style=""BACKGROUND-COLOR:{3}"">[{0}] - {1}</font></div>"

This sets up a constant, a template for the display text.

The following code is the update to make it all work:

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
Dim blnRetVal
 Dim sBackgroundColor As String, sForeColor As String
 
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 tblEvents "
 'strSQL = strSQL & "WHERE tblEvents.Status <> 'Cancelled' And tblEvents.[StartDate] Between " & lngFirstOfMonth & " And " & lngLastOfMonth &
 strSQL = strSQL & "WHERE tblEvents.[StartDate] Between " & lngFirstOfMonth & " And " & lngLastOfMonth & _
                  " ORDER BY tblEvents.[StartDate];"
 
Set rstEvents = db.OpenRecordset(strSQL)    'Added 4/16/2008
 
Do While Not rstEvents.EOF
 
   ' Determine Background Color
   Select Case Nz(rstEvents![Status], "Tentative")
     Case "Tentative", "Confirmed", "Completed"
       sForeColor = "#000077"
       sBackgroundColor = "#FFFFFF"
     Case "Cancelled"
       sForeColor = "#AA0000"
       sBackgroundColor = "#FFFF00"
     Case Else
       sForeColor = "#000077"
       sBackgroundColor = "#FFFFFF"
   End Select
 
   ' Generate Display Text
   'strEvent = "[" & rstEvents![EventID] & "] - " & rstEvents![EventName]
   strEvent = nAppointmentTemplate
   strEvent = Replace(strEvent, "{0}", Nz(rstEvents![EventID], ""))
   strEvent = Replace(strEvent, "{1}", Nz(rstEvents![EventName], ""))
   strEvent = Replace(strEvent, "{2}", sForeColor)
   strEvent = Replace(strEvent, "{3}", sBackgroundColor)
 
   ' Find Day
  bytEventDayOfMonth = (rstEvents!StartDate - lngLastOfPreviousMonth)
  bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
 
    If astrCalendarBlocks(bytBlockCounter) <> "" Then
      astrCalendarBlocks(bytBlockCounter) = _
      astrCalendarBlocks(bytBlockCounter) & vbNewLine & strEvent
    Else
      astrCalendarBlocks(bytBlockCounter) = strEvent
    End If
    rstEvents.MoveNext
Loop
...

[sheepchild]

not quite sure where this should be sitting?

you say "The following code will need to be placed at the Top of the Code for the fdlgEventDetails:"

Private Const nAppointmentTemplate = "<div><font color={2} style=""BACKGROUND-COLOR:{3}"">[{0}] - {1}</font></div>"

is that on click or load or something or???

[sheepchild]

Found the place for this to sit i have put it at the top of the frm_calendar which then made it work. is that correct?

[sheepchild]

Thanks jforbes, you have been a massive help.

[jforbes]

Ahh, yes. The Constant is to be placed at the top of frmCalendar instead of fdlgEventDetails. Glad you figured out what I meant instead of what I posted.

[sheepchild]

just an addition to this just to make it easier to change the colours etc... if need be, i thought it would be nice to be able to get the colour codes from a table.

tbl_dbcolours

have the colours in there under heading HexValue and the status in object

i was trying

  Select Case Nz(rstEvents![Status], "Confirmed")
    Case "Confirmed"
      sForeColor = DLookup("[HexValue]", "tbl_dbColours", "[Object]")
      'sForeColor = "#000077"
      'sBackgroundColor = "#FFFFFF"
    Case "Provisional"
      sForeColor = DLookup("[HexValue]", "tbl_dbColours", "[Object]")
      'sForeColor = "#EE4000"
      'sBackgroundColor = "#FFFFFF"
      Case "Offered"
      sForeColor = DLookup("[HexValue]", "tbl_dbColours", "[Object]")
      'sForeColor = "#E3CF57"
      'sBackgroundColor = "#FFFFFF"
    Case "Cancelled"
      sForeColor = DLookup("[HexValue]", "tbl_dbColours", "[Object]")
      'sForeColor = "#A1A1A1"
      'sBackgroundColor = "#FFFF00"
    Case Else
      sForeColor = "#000077"
     'sBackgroundColor = "#FFFFFF"
  End Select
 

but was getting stuck with the last bit with the object in didnt know how to reffernce the case "confirmed" etc...

[jforbes]

I think your looking for something like this for your criteria:

   Select Case Nz(rstEvents![Status], "Confirmed")
     Case "Confirmed"
       sForeColor = DLookup("[HexValue]", "tbl_dbColours", "[Object]='" & Nz(rstEvents![Status], "Confirmed") & "'")
...

Since your going to be using the Status over and over, you might want to put in it in a Variable. It's a best practice, to make the code easier to read and often times speeds up the code:

   Dim sStatus As String
   sStatus = Nz(rstEvents![Status], "Confirmed")
 
   Select Case sStatus 
     Case "Confirmed"
       sForeColor = DLookup("[HexValue]", "tbl_dbColours", "[Object]='" & sStatus & "'" )
...

[PhilOfWalton]

Wouldn't be easier & more flexible to have a table of Statuses

TblStatus
    StatusID           Autonumber   PK
    Status             Text         Unique
    StatusForeColour   Long
    StatusBackColour   Long
 
 

Then the Combobox on the fdlgEventDetails form becomes a lookup from the table and the status would automatically have the relevant colours available.

Phil

[sheepchild]

getting an error of

"invalid use of null"

with both?

[jforbes]

Typically, if you get "Invalid use of Null" and your using a DLookup, it's because the DLookup is not finding a record to return; the Criteria argument can't match a record. You can verify this running the code with a Break Point on the line with the Select Case and then typing the following into the Immediate Window:

?DLookup("[HexValue]", "tbl_dbColours", "[Object]='" & sStatus & "'" )

Access will tell you if is returning a Null. If so, start verifying that the value that is in sStatus is truly in the tbl_dbColours.Object. If it's not, then you found your bug.