Conditional Formatting (1 Viewer)

[Noson5434]

Hey folks,

I could use some help with my VBA code. Here's the issue I'm facing:

I have a UNION query that shows contracts with multiple items, and I'm trying to color each group in a continuous form. So, let's say ID 27 has two values displayed continuously, I want both of them to have the same color. The same goes for ID 28 and its own unique color, and so on.

The code I'm using works fine, but I hit a snag after assigning three grouped colors:

Error Number: 7966
Error Description: The format condition number you specified is greater than the number of format conditions.

Is there any way around this? Am I doing something wrong? I'd appreciate any help or advice you can offer!

' Purpose: Apply conditional formatting to the ContractID control based on unique ContractID values in the recordset
Private Sub ApplyConditionalFormatting()
    On Error GoTo Err_Handler

    Dim objFrc As Access.FormatCondition    ' FormatCondition object for adding format conditions
    Dim rst As DAO.Recordset                ' Recordset object for cloning the form's recordset
    Dim currentContractID As Variant        ' Current ContractID value from the recordset
    Dim color As Long                       ' Color value for the format condition
    Dim contractIDs As Object               ' Dictionary object for storing unique ContractID values
    
    ' Remove existing format conditions for the ContractID control
    Me.ContractID.FormatConditions.Delete
    
    ' Clone the recordset of the form
    Set rst = Me.RecordsetClone
    
    ' Create a Dictionary to store unique ContractID values
    Set contractIDs = CreateObject("Scripting.Dictionary")
    
    ' Loop through the recordset
    Do Until rst.EOF
        ' Get the ContractID value from the current record
        currentContractID = rst("ContractID").Value
        
        ' Check if the currentContractID is not null
        If Not IsNull(currentContractID) Then
            ' Check if the currentContractID is not already in the Dictionary
            If Not contractIDs.Exists(currentContractID) Then
                ' Add the currentContractID to the Dictionary
                contractIDs(currentContractID) = True
                
                ' Generate a random color for the currentContractID group
                color = GenerateRandomColor()
                
                ' Add a format condition for the currentContractID group
                Set objFrc = Me.ContractID.FormatConditions.Add(acExpression, acEqual, "[ContractID] = " & currentContractID)
                
                ' Set the back color of the format condition
                objFrc.BackColor = color
                objFrc.Enabled = True
            End If
        End If
        
        ' Move to the next record in the recordset
        rst.MoveNext
    Loop
    
    Me.Refresh
    Set rst = Me.RecordsetClone

Exit_Err_Handler:
    ' Cleanup
    rst.Close
    Set rst = Nothing
    Set objFrc = Nothing
    Set contractIDs = Nothing
    Exit Sub

Err_Handler:
    MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description & vbCrLf & "Procedure: ApplyConditionalFormatting", vbCritical + vbOKOnly, "ApplyConditionalFormatting - Error"
    Resume Exit_Err_Handler
End Sub

' Purpose:  Check if the ContractID exists in the format conditions
Private Function ContractIDExists(ByVal ContractID As Variant, ByVal FormatConditions As Access.FormatConditions) As Boolean
    On Error GoTo Err_Handler
    
    Dim objFrc As Access.FormatCondition    ' FormatCondition object for iterating through format conditions
    
    ' Loop through the format conditions
    For Each objFrc In FormatConditions
        If objFrc.Expression1 = "[ContractID] = " & ContractID Then
            ' ContractID exists in format conditions
            ContractIDExists = True
            Exit Function
        End If
    Next objFrc
    
    ' ContractID does not exist in format conditions
    ContractIDExists = False
    
Exit_Err_Handler:
    Exit Function

Err_Handler:
    ' Handle the error gracefully
    MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description & vbCrLf & "Procedure: ContractIDExists", vbCritical + vbOKOnly, "ContractIDExists - Error"
    Resume Exit_Err_Handler
End Function

' Purpose:  Generate a random RGB color
Private Function GenerateRandomColor() As Long
    On Error GoTo Err_Handler
    
    ' Declarations
    Dim red As Integer      ' Red component of the color
    Dim green As Integer    ' Green component of the color
    Dim blue As Integer     ' Blue component of the color
    
    ' Generate random values for red, green, and blue components
    red = Int((200 - 100 + 1) * Rnd + 100)      ' Generate random value between 100 and 200
    green = Int((200 - 100 + 1) * Rnd + 100)    ' Generate random value between 100 and 200
    blue = Int((200 - 100 + 1) * Rnd + 100)     ' Generate random value between 100 and 200
    
    ' Create RGB color from random values
    GenerateRandomColor = RGB(red, green, blue)
    
Exit_Err_Handler:
    Exit Function

Err_Handler:
    ' Handle the error gracefully
    MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description & vbCrLf & "Procedure: GenerateRandomColor", vbCritical + vbOKOnly, "GenerateRandomColor - Error"
    Resume Exit_Err_Handler
End Function

 

[Noson5434]

Attached is an image of my form.
As you can see, it successfully applies the grouped colors for the first three groups. However, it stops functioning properly after that point.

 

[theDBguy]

Which version of Access are you using? You can have up to 50 CFs since Access 2007 or 2010 (I think).

 

[Noson5434]

Which version of Access are you using? You can have up to 50 CFs since Access 2007 or 2010 (I think).

I am using Access 2016

 

[tvanstiphout]

Is there a chance you're always adding formatconditions, and never removing them?
Write a procedure to dump the list to the Immediate window, just for debugging purposes.

 

[Noson5434]

Is there a chance you're always adding formatconditions, and never removing them?
Write a procedure to dump the list to the Immediate window, just for debugging purposes.

I will give that a try and post the results

 

[Noson5434]

Is there a chance you're always adding formatconditions, and never removing them?
Write a procedure to dump the list to the Immediate window, just for debugging purposes.

So I used the following function to Dump the results into the Immediate window.

Private Sub DumpFormatConditions()
    Dim objFrc As Access.FormatCondition
    For Each objFrc In Me.ContractID.FormatConditions
        Debug.Print objFrc.Expression1
    Next objFrc
End Sub

And the results were
[ContractID] = 27
[ContractID] = 28
[ContractID] = 29

 

[theDBguy]

What do you get with something like this?

Debug.Print Me.ContractID.FormatConditions.Count

 

[Noson5434]

What do you get with something like this?

Debug.Print Me.ContractID.FormatConditions.Count

3

 

[theDBguy]

3

That's definitely less than 50. Are you able to post a sample db, so we can test it out?

 

[Noson5434]

That's definitely less than 50. Are you able to post a sample db, so we can test it out?

I will work on a sample db and post soon.

 

[Noson5434]

I managed to find a solution that doesn't require VBA. Instead of using a UNION query, I created a stored procedure (SP) that generates a RecordCount. Then, on the form, I set the RecordCount to be invisible (Visible = False) and used the ContractID Expression RecordCount > 1. This successfully resolved the problem I was facing. The only difference is that all the colors are now the same and not unique RGB colors.

 

[theDBguy]

I managed to find a solution that doesn't require VBA. Instead of using a UNION query, I created a stored procedure (SP) that generates a RecordCount. Then, on the form, I set the RecordCount to be invisible (Visible = False) and used the ContractID Expression RecordCount > 1. This successfully resolved the problem I was facing. The only difference is that all the colors are now the same and not unique RGB colors.

Glad to hear you got it sorted out. Good luck with your project.