[VB6] How Can I Make A ListBox Display Colours?
CodeGuru Home VC++ / MFC / C++ .NET / C# Visual Basic VB Forums Developer.com
Results 1 to 1 of 1

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

Hybrid View

  1. #1
    Join Date
    Jul 2001
    Sunny South Africa

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

    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.
            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
                    '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_BTNFACE = 15
      COLOR_BTNTEXT = 18
      COLOR_MENU = 4
      COLOR_WINDOW = 5
    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.
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Azure Activities Information Page

Windows Mobile Development Center

Click Here to Expand Forum to Full Width

This is a CodeGuru survey question.


HTML5 Development Center