MultiSelect ListBox BackColor Will Not Change

[JTBorton]

All,

I have a userform with a multiselect listbox used for search and filter options. When the user selects a value in the list box I want it to highlight light green to indicate to the user that a filter is in place. However for a multiselect listbox it will not change the backcolor - at all. Even if I set the backcolor of the listbox in the form design it is changed back to white when the form runs. Does anyone know how to change the backcolor of a multiselect listbox?

Private Sub lstField2_Change()
    If Loading = True Then: Exit Sub
    If HasItemsSelected(lstField2) = True Then
        [highlight]lstField2.BackColor = lngcButtonColorGreen[/highlight]
    Else
        lstField2.BackColor = lngcFontColorWhite
    End If
End Sub

Public Function HasItemsSelected(ListBox As MSForms.Control, Optional ExceptIDs As Variant) As Boolean
    Dim F           As Long
    Dim G           As Long
    Dim lngIDs()    As Long
    Dim lngCount    As Long
    Dim vntCatch    As Variant
    
    If TypeOf ListBox Is MSForms.ListBox Or TypeOf ListBox Is MSForms.ComboBox Then
        If ListBox.ListCount > 0 Then
            lngIDs = ExtractIDs(ExceptIDs, False)
            On Error Resume Next
                lngCount = UBound(lngIDs)
            On Error GoTo 0
            For F = 0 To ListBox.ListCount - 1
                If ListBox.Selected(F) = True Then
                    HasItemsSelected = True
                    
                    'Test exceptions
                    If lngCount > 0 Then
                        vntCatch = ListBox.List(F, 0)
                        If IsNumeric(vntCatch) Then
                            For G = 1 To lngCount
                                If vntCatch = lngIDs(G) Then
                                    HasItemsSelected = False
                                    Exit For
                                End If
                            Next G
                        End If
                    End If
                    
                    If HasItemsSelected = True Then
                        Exit For
                    End If
                End If
            Next F
        End If
    End If
End Function

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[combo]

It's not a problem with listbox. I would check the visibility of colour storing variables (lngcButtonColorGreen, lngcFontColorWhite) and value returned by HasItemsSelected in the event procedure.

combo

 

[JTBorton]

combo,

The HasItemsSelected function is well tested and works perfectly. It is a function that I have adapted to use throughout numerous programming projects. But, just to make sure, I stepped through the function as you suggested and found no issues. When a any option is selected in the listbox (the listbox is set as fmListStyleOption and fmMultiSelectMulti - so it is a multiselect checkbox), except for the exceptions specified in the second parameter, the function returns a value of TRUE.

The color constants are defined in a public global module as follows:

[indent]Public Const lngcFontColorWhite         As Long = &H80000005[/indent]
[indent].... (numerous other color contants) ...[/indent]
[indent]Public Const lngcButtonColorGreen       As Long = &HC0FFC0[/indent]
[indent]Public Const lngcButtonColorGrey        As Long = &H8000000F[/indent]
[indent]... (continues) ...[/indent]

Since posting this I have discovered that the code will execute properly for the color constant lngcButtonColorGrey, but only once and then never again - not even to change back to white.

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[combo]

Looks like the "change" event does not change background colour of the listbox that rises this event.
For the list with single selection the "afterupdate" event works, but fails in case of nultiselect set to multi.
Mouse and key events still work.

combo

 

[Andrzejek]

Instead of Change() event, have you considered using
[tt]Private Sub lstField2_Click()[/tt] event?


Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[JTBorton]

Andrzejek,

That's a great thought, but unfortunately when a listbox control is switched to MultiSelect the _Click() and _AfterUpdate() events no longer function when a user clicks on the list box. Instead you must use the _Change() event.

combo,

The mouse event was a great idea, and it worked. However it opened up some new issues -

First, when the list box changes background color it un-selects all previously selected items. This of course was corrected with some simple coding with arrays to re-select the items.

Second, the event runs continuously as long as the user has the mouse over the list box and moves it even the slightest pixel, causes the list box to continuously flicker as it unloads and reloads items. This was corrected by adding a static array to compare the new selections with previous selections in order to determine if a change has been made; then, if changed, modify the background color and reload the selections.

Now I am working on the final problem - when the list box reloads the selected items it scrolls back up to the top of the list box. So every time you scroll down and click an item it jumps back to the top of the list. The .ListIndex and .Value properties no longer apply in a MultiSelect listbox, so I am trying to find a way to restore the listbox to the last scroll location. Any ideas?

Here is my code:

Private Sub lstField1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim blnSelected()       As Boolean
    Static blnPrevious()    As Boolean
    Dim F                   As Long
    Dim H                   As Long
    Dim lngIndex            As Long
    
    If Loading = True Then: Exit Sub
    If HasItemsSelected(lstField1, Array(0, -1)) = True Then
        ReDim blnSelected(1 To lstField1.ListCount)
        On Error Resume Next
            H = UBound(blnPrevious)
        On Error GoTo 0
        If H <= 0 Then
            ReDim Preserve blnPrevious(1 To lstField1.ListCount)
        End If
        For F = 1 To lstField1.ListCount
            blnSelected(F) = lstField1.Selected(F - 1)
        Next F
        For F = 1 To lstField1.ListCount
            If blnSelected(F) <> blnPrevious(F) Then
                lstField1.BackColor = lngcButtonColorGreen
                Loading = True
                    lngIndex = lstField1.ListIndex
                    For H = 1 To lstField1.ListCount
                        lstField1.Selected(H - 1) = blnSelected(H)
                    Next H
                Loading = False
                blnPrevious = blnSelected
                lstField1.ListIndex = lngIndex
                Exit For
            End If
        Next F
    Else
        lstField1.BackColor = lngcFontColorWhite
    End If
End Sub

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[combo]

TopIndex indicates top visible row, r/w.
Instead of MouseMove you can use MouseUp event, it may be simpler to handle.

combo

 

[JTBorton]

combo

That works perfectly, thanks! Here is my final solution:

In the User Form

Private Sub lstField1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AdjustListFilterBackground(ListBox:=lstField1, ExceptionIDs:=Array(0, -1), SourceLoadingVar:=Loading)
End Sub

Private Sub lstField2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AdjustListFilterBackground(ListBox:=lstField2, ExceptionIDs:=Array(0, -1), SourceLoadingVar:=Loading)
End Sub

Private Sub lstField3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AdjustListFilterBackground(ListBox:=lstField3, ExceptionIDs:=Array(0, -1), SourceLoadingVar:=Loading)
End Sub

Private Sub lstField4_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AdjustListFilterBackground(ListBox:=lstField4, ExceptionIDs:=Array(0, -1), SourceLoadingVar:=Loading)
End Sub

Private Sub lstField5_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AdjustListFilterBackground(ListBox:=lstField5, ExceptionIDs:=Array(0, -1), SourceLoadingVar:=Loading)
End Sub

Private Sub lstField6_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AdjustListFilterBackground(ListBox:=lstField6, ExceptionIDs:=Array(0, -1), SourceLoadingVar:=Loading)
End Sub

In a Public Module:

Public Const lngcFontColorWhite         As Long = &H80000005
Public Const lngcButtonColorGreen       As Long = &HC0FFC0
Public Const lngcButtonColorGrey        As Long = &H8000000F

Public Sub AdjustListFilterBackground(ByRef ListBox As MSForms.Control, Optional ByVal AllowColorChange As Boolean = True, Optional ByVal ExceptionIDs As Variant, Optional ByRef SourceLoadingVar As Boolean)
    'ListBox - the listbox being formatted
    'AllowColorChange - an optional setting to ignore list items and force a white background
    'ExceptionIDs - list items that will be ignored when testing if a filter has been selected
    'SourceLoadingVar - the loading boolean variable in the calling form
    
    Dim blnSelected()       As Boolean
    Dim F                   As Long
    Dim H                   As Long
    Dim lngIndex            As Long
    
    If TypeOf ListBox Is MSForms.ListBox Then
        lngIndex = -1
        If ListBox.ListCount > 0 Then
            lngIndex = ListBox.TopIndex
            ReDim blnSelected(1 To ListBox.ListCount)
            For F = 1 To ListBox.ListCount
                 blnSelected(F) = ListBox.Selected(F - 1)
            Next F
            If AllowColorChange = True And HasItemsSelected(ListBox:=ListBox, ExceptIDs:=ExceptionIDs) = True Then
                ListBox.BackColor = lngcButtonColorGreen
            Else
                ListBox.BackColor = lngcFontColorWhite
            End If
            SourceLoadingVar = True 'Prevent the listbox Change event from executing
                For H = 1 To ListBox.ListCount
                    ListBox.Selected(H - 1) = blnSelected(H)
                Next H
            SourceLoadingVar = False
            ListBox.TopIndex = lngIndex
        Else
            ListBox.BackColor = lngcFontColorWhite
        End If
    End If
End Sub

Public Function HasItemsSelected(ByRef ListBox As MSForms.Control, Optional ByVal ExceptIDs As Variant) As Boolean
    Dim F           As Long
    Dim G           As Long
    Dim lngIDs()    As Long
    Dim lngCount    As Long
    Dim vntCatch    As Variant
    
    If TypeOf ListBox Is MSForms.ListBox Or TypeOf ListBox Is MSForms.ComboBox Then
        If ListBox.ListCount > 0 Then
            lngIDs = ExtractIDs(Variable:=ExceptIDs, ForceDefault:=False)
            On Error Resume Next
                lngCount = UBound(lngIDs)
            On Error GoTo 0
            For F = 0 To ListBox.ListCount - 1
                If ListBox.Selected(F) = True Then
                    HasItemsSelected = True
                    
                    'Test exceptions
                    If lngCount > 0 Then
                        vntCatch = ListBox.List(F, 0)
                        If IsNumeric(vntCatch) Then
                            For G = 1 To lngCount
                                If vntCatch = lngIDs(G) Then
                                    HasItemsSelected = False
                                    Exit For
                                End If
                            Next G
                        End If
                    End If
                    
                    If HasItemsSelected = True Then
                        Exit For
                    End If
                End If
            Next F
        End If
    End If
End Function

Public Function ExtractIDs(Variable As Variant, Optional ForceDefault As Boolean = False, Optional DefaultValue As Long = 0) As Long()
    'Extracts an array if IDs out of a variant datatype
    'The ForceDefault parameter sets the ExtractIDs function to always returns atleast one array element (the default value)
    
    Dim vntCatch    As Variant
    Dim lngArray()  As Long
    Dim lngCount    As Long
    
    If IsEmpty(Variable) Then
        If ForceDefault = True Then
            ReDim lngArray(1 To 1)
            lngArray(1) = DefaultValue
        End If
    ElseIf IsArray(Variable) Then
        For Each vntCatch In Variable
            If IsNumeric(vntCatch) Then
                lngCount = lngCount + 1
                ReDim Preserve lngArray(1 To lngCount)
                lngArray(lngCount) = CLng(vntCatch)
            End If
        Next vntCatch
        If lngCount = 0 And ForceDefault = True Then
            ReDim lngArray(1 To 1)
            lngArray(1) = DefaultValue
        End If
    Else
        If IsNumeric(Variable) Then
            ReDim lngArray(1 To 1)
            lngArray(1) = CLng(Variable)
        Else
            If ForceDefault = True Then
                ReDim lngArray(1 To 1)
                lngArray(1) = DefaultValue
            End If
        End If
    End If
    
    ExtractIDs = lngArray()
    
End Function

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[strongm]

You could always use a ListView instead ...

 

[JTBorton]

strongm,

That would certainly be an easier solution, however this application must be able to run on any version of excel from 2003 forward, regardless of the user's licensing. I certainly like the listview much more but I have found it to be unreliable in terms of universal compatibility. Then, of course, it doesn't matter if the problem is in the user's licensing agreements, nor does it matter how truly clever or flashy your code is - when it doesn't work people simply assume you are an incompetent programmer and your applications aren't reliable. End users can be real stubborn cynical bastards, especially in an engineering environment. But I digress...

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[strongm]

Um... I was pretty certain that the common controls shipped with Office 2003 SP3 and later. Perhaps my memory is letting me down. Oh well.

 

[JTBorton]

It does, but sometimes the user licensing does not allow it to be used. I can't tell you why, all I can tell you is that I have seen instances where people using using 2003, and 2007 were unable to use applications with the common control reference library due to licensing issues.

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[combo]

AFAIK, common controls licensing may allow using controls in runtime, but not in development environment. Password protection of vba project will allow to use them in vba applications in this case.

combo

 

[strongm]

AFAIK, the Common Controls that ship with Office include the necessary license.

 

[JTBorton]

combo ...that's awesome news! I was unaware that it will work as long as the VBA project is password protected. That's really good news! I must find a guinea pig ASAP to test this out.

What about conflicting reference libraries? The DTPicker control at work uses a mscomct2.ocx library that doesn't seem to be recognized even on my own computer. I always have to manually change the 'Missing' reference library to my computer's version of the mscomct2.ocx file. Then do it again when I bring the file back to work. You guys know of any workarounds for this? Of course I could replace my mscomct2.ocx file with the file version at work, but that is not a universal solution for other users.

-Joshua
If it's not broken, it doesn't have enough parts yet.

 

[combo]

Ms common controls 6 are available at

http://www.microsoft.com/en-us/download/details.aspx?id=10019.

Long time ago I had problem with switching from v5 to v6, I had to add new and delete old controls on my userform.
It is possible to programmatically add reference, but this requires permission to programmatically access vba project.

combo