[VB6] How Can I Make A ListBox Display Colours?

[HanneSThEGreaT]

Q: Can An Ordinary ListBox Show Colours?

A: Yes, it can, but with a lot of effort. What we would need to do is to override some of the ListBox's Properties. This means that instead of behaving as a normal ListBox, we make it behave and act differently.

Q: You Talk About Overriding The ListBox Properties, What Does This Entail And How?

A: Well, in order to do this, involves 2 APIs. SetWindowLong and SendMessage. It also involves a procedure / function that replaces the previous "normal" ListBox behaviour. For this example we will show the System Colours inside the ListBox.

Q: Where Do We Start?

A: Add a Module to your project, and add the following APIs and their associated Constants :

Option Explicit

'APIs To "OwnerDraw" A ListBox, And Override Any Of The ListBox's Events

'Describes the width, height, and location of a rectangle.
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

'Provides necessary information the owner window to determine how to paint an owner-drawn control or menu item.
Public Type DRAWITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemAction As Long
        itemState As Long
        hwndItem As Long
        hdc As Long
        rcItem As RECT
        itemData As Long
End Type

'Copies a block of memory from one location to another
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'The SetWindowLong function changes an attribute of the specified window.
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'The CallWindowProc function passes message information to the specified window procedure.
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

'Sends the specified message to a window or windows
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'This function creates a logical brush that has the specified solid color
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

'This function fills a rectangle using the specified brush
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

'This function deletes a logical pen, brush, font, bitmap, region, or palette, freeing all system resources associated with the object
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'The SetBkColor function sets the current background color to the specified color value
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

'The SetTextColor function sets the text color for the specified device context to the specified color.
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

'The TextOut function writes a character string at the specified location, using the currently selected font, background color, and text color
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

'Draws a rectangle in the style used to indicate that the rectangle has the focus
Public Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

'Retrieves the current color of the specified display element
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Public Const LB_GETTEXT = &H189 'Gets a string from a list box
Public Const WM_DRAWITEM = &H2B 'Sent to the parent window of an owner-drawn button, combo box, list box, or menu when a visual aspect of the button, combo box, list box, or menu has changed.
Public Const GWL_WNDPROC = (-4) 'Sets a new address for the window procedure
Public Const ODS_FOCUS = &H10
Public Const ODT_LISTBOX = 2

Public lPrevWndProc As Long

Q: When And Where Do I Add The "Overriding Function"?

A: Now and next :

'Function To Override ListBox Colours
'hwnd = ListBox Window Handle
'Msg = Message To Send
'wParam & lparam = What Message to Send

Public Function OverrideList(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim tItem As DRAWITEMSTRUCT
    Dim sBuff As String * 255
    Dim sItem As String
    Dim lBack As Long

    If Msg = WM_DRAWITEM Then
        'Redraw ListBox
         Call CopyMemory(tItem, ByVal lParam, Len(tItem))

        'Is The Control Indeed A ListBox ¿
        If tItem.CtlType = ODT_LISTBOX Then
            'Get Current Item's Text
            Call SendMessage(tItem.hwndItem, LB_GETTEXT, tItem.itemID, ByVal sBuff)
            sItem = Left(sBuff, InStr(sBuff, Chr(0)) - 1)

            If (tItem.itemState And ODS_FOCUS) Then
                'If Item Has Focus - Highlight it
                lBack = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))

               'Fill Item's Rect
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                'BackColour Of Item
                Call SetBkColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHT))

                'TextColour Of Item
                Call SetTextColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))

                'Draw The Text
                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)
                DrawFocusRect tItem.hdc, tItem.rcItem
            Else
                'Item Doesn't Have Focus - Draw it's Coloured Background
                'Use Colour From ItemData
                lBack = CreateSolidBrush(tItem.itemData)

                'Fill Item's Rect
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)

                'BackColour Of Item
                Call SetBkColor(tItem.hdc, tItem.itemData)

                'TextColour Of Item
                Call SetTextColor(tItem.hdc, IIf(tItem.itemData = vbBlack, vbWhite, vbBlack))

                'Draw The Text
                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)
            End If
            Call DeleteObject(lBack)

            'Don't Pass a Value
            OverrideList = 0
            Exit Function

        End If

    End If

    OverrideList = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)
End Function

Q: What Is Needed On The Form?

A: Add a ListBox and set it's Style Property To 1 - CheckBox. In this example, mine is named lstSysColors

Q: What is Needed On The Form's Coding Side?

A: Add the following APIs and Constants and Enumerations :

'APIs For Getting & Setting System Colours
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long

'Enum For System Colours
Public Enum enSystemColours
  COLOR_ACTIVEBORDER = 10
  COLOR_ACTIVECAPTION = 2
  COLOR_APPWORKSPACE = 12
  COLOR_BACKGROUND = 1
  COLOR_BTNFACE = 15
  COLOR_BTNHIGHLIGHT = 20
  COLOR_BTNSHADOW = 16
  COLOR_BTNTEXT = 18
  COLOR_CAPTIONTEXT = 9
  COLOR_GRAYTEXT = 17
  COLOR_HIGHLIGHT = 13
  COLOR_HIGHLIGHTTEXT = 14
  COLOR_INACTIVEBORDER = 11
  COLOR_INACTIVECAPTION = 3
  COLOR_INACTIVECAPTIONTEXT = 19
  COLOR_MENU = 4
  COLOR_MENUTEXT = 7
  COLOR_SCROLLBAR = 0
  COLOR_WINDOW = 5
  COLOR_WINDOWFRAME = 6
  COLOR_WINDOWTEXT = 8
End Enum

Add the following Properties to the Form :

'Property For Colours
Public Property Get SystemColours(ColourID As enSystemColours) As Long
  SystemColours = GetSysColor(ColourID)
End Property

'Sub to Load & Apply Colours To ListBox
Private Sub LoadColours(Colour As Long, ColName As String)

lstSysColors.AddItem ColName
lstSysColors.itemData(lstSysColors.NewIndex) = Colour
End Sub

Add the Form_Initialize method :

'Load & Apply Colours, Before Form Is Shown
Private Sub Form_Initialize()
    'Call The LoadColours Sub To Apply The System Colours
    'Via The System COlour's ID And "Known" Name
    Call LoadColours(Me.SystemColours(COLOR_ACTIVECAPTION), "Active Caption")
    Call LoadColours(Me.SystemColours(COLOR_APPWORKSPACE), "Application Workspace")
    Call LoadColours(Me.SystemColours(COLOR_BACKGROUND), "Background")
    Call LoadColours(Me.SystemColours(COLOR_BTNFACE), "Button Face")
    Call LoadColours(Me.SystemColours(COLOR_BTNHIGHLIGHT), "Button Highlight")
    Call LoadColours(Me.SystemColours(COLOR_BTNSHADOW), "Button Shadow")
    Call LoadColours(Me.SystemColours(COLOR_BTNTEXT), "Button Text")
    Call LoadColours(Me.SystemColours(COLOR_CAPTIONTEXT), "Caption Text")
    Call LoadColours(Me.SystemColours(COLOR_GRAYTEXT), "Grayed Text")
    Call LoadColours(Me.SystemColours(COLOR_HIGHLIGHT), "Highlight")
    Call LoadColours(Me.SystemColours(COLOR_HIGHLIGHTTEXT), "Highlighted Text")
    Call LoadColours(Me.SystemColours(COLOR_INACTIVEBORDER), "Inactive Border")
    Call LoadColours(Me.SystemColours(COLOR_INACTIVECAPTION), "Inactive Caption")
    Call LoadColours(Me.SystemColours(COLOR_INACTIVECAPTIONTEXT), "Inactive Caption Text")
    Call LoadColours(Me.SystemColours(COLOR_MENU), "Menu")
    Call LoadColours(Me.SystemColours(COLOR_MENUTEXT), "Menu Text")
    Call LoadColours(Me.SystemColours(COLOR_SCROLLBAR), "ScrollBar")
    Call LoadColours(Me.SystemColours(COLOR_WINDOW), "Window")
    Call LoadColours(Me.SystemColours(COLOR_WINDOWFRAME), "Window Frame")
    Call LoadColours(Me.SystemColours(COLOR_WINDOWTEXT), "Window Text")
    

End Sub

Add the Form_Load and Form_Unload events :

Private Sub Form_Load()

    'Subclass Form To Recieve All Listbox Messages
    lPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf OverrideList)

End Sub

Private Sub Form_Unload(Cancel As Integer)

    'Release SubClassing
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWndProc)
    
End Sub

A Full Working Sample Is Attached To This Post.