Tabs and checkbox in listbox

[James Stanich]

I'm trying to display multiple columns in a listbox. That;s no problem using SENDMESSAGE, but only if the listbox style is set to 0. If I set it to 1, I can get multiple columns, but the alignment is all out of whack.

Any suggestions?

[Jop]

http://www.mvps.org/vbnet/code/listapi/listboxtabs.htm

Does this help you?

[James Stanich]

I am using similiar code to get the columns to align. What Ia am syaing is that when the listbox style is set to chkbox that is when the same exact code does not work. Any suggestions?

[Jop]

ehrmmm... No, I'm sorry, but look at http://www.vbaccelerator.com, http://www.mvps.org/vbnet/ and http://www.allapi.com for more info.

[James Stanich]

I looked and could not find anything but the code to perform it. Can anyone give me any feedback on whether they have got this to work?

PROBLEM AGAIN: Added tabs in listbox, that code works fine, except when the listbox style is set to chkbox. Anyone please? ? ?

[James Stanich]

I know I'm beating this to death, but it's beating me. Has anyone figured out how correctly use tabs in listbox with style of checkbox?

[James Stanich]

Ok. My last attempt to find out:

I there a way to erform this task. I worked with the problem late into last night bu could not figure it out.

Please, please?

[Aaron Young]

You could Subclass the whole Listbox then you could do pretty much anything you want, I've taken some of my code I've been playing around with and added functionality to set Column widths for a Listbox (including/excluding checkboxes)...

Add a Listbox to your Form and set the Style property to 1 - Checkbox (needs to be set to this to enable the control as Owner Drawn), then add this code:

In a Module:

'>>>>>>>>>>>>>>>>>>>>>> ListBoxEx <<<<<<<<<<<<<<<<<<<<<<
' Subclassing for a Standard VB Listbox which extended it's properties
' to include the ability to set Columns/Widths,
' Multicolor list items
' and runtime Checkbox activation/deactivation
'
' Written by Aaron Young
' [email protected]
'
' **Work in progress.
'
Option Explicit

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private 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

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private 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
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, lpBitmapName As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetBkMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long

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

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest

Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_WINDOW = 5
Private Const COLOR_WINDOWTEXT = 8

Private Const GWL_WNDPROC = (-4)

Private Const OBM_CHECK = 32760
Private Const OBM_CHECKBOXES = 32759

Private Const ODS_FOCUS = &H10
Private Const ODS_CHECKED = &H8
Private Const ODS_SELECTED = &H1
Private Const ODS_DISABLED = &H4
Private Const ODS_GRAYED = &H2

Private Const ODT_LISTBOX = 2

Private Const WM_DRAWITEM = &H2B
Private Const WM_USER = &H400

Private Const LB_GETTEXT = &H189
Private Const LB_SETTABSTOPS = &H192
Private Const LB_GETITEMDATA = &H199
Private Const LB_GETITEMHEIGHT = &H1A1
Private Const LB_GETITEMRECT = &H198
Private Const LB_GETTOPINDEX = &H18E
Private Const LB_SELITEMRANGEEX = &H183
Private Const LB_SELITEMRANGE = &H19B
Private Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188
Private Const LB_GETCOUNT = &H18B

'Create some user defined window messages
Public Const UD_SETLISTCOLS = WM_USER + 1
'Set the Columns/Widths, wParam = Listbox Hwnd, lParam = Comma Delimited String of column Widths

Public Const UD_USECHECKBOXES = WM_USER + 2
'Turn Listbox Columns on/off, wParam = Listbox Hwnd, lParam = True/False to Turn Checkboxes On/Off

'Create a UDT to track extended properties of the listbox(es)
Private Type tListBoxEx
    hwnd As Long                'Listbox Window Handle
    Columns As String           'Comma Delimited List of Column Widths
    Checkboxes As Boolean       'Use Checkboxes?
End Type

Private lPrevWndProc As Long
Private uListBoxes() As tListBoxEx
Private lLists As Long

Function FindHwnd(ByVal lHwnd As Long) As Long
    'Find a Windows Entry in the UDT Array if it exists and return the Index
    Dim lItem As Long
    For lItem = 1 To lLists
        If uListBoxes(lItem).hwnd = lHwnd Then
            FindHwnd = lItem
            Exit For
        End If
    Next
End Function

Private Function SubClassedList(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 lFound As Long
    Dim sCols As String
    Dim lLen As Long
    
    Select Case Msg
    
    'If we receive our User Defined Message for setting the Column Widths of a Listbox...
    Case UD_SETLISTCOLS
        'Retreive the Comma Delimited List of Columns Widths passed in the "lParam" parameters of the Message
        lLen = lstrlen(lParam)
        sCols = Space(lLen)
        Call lstrcpy(ByVal sCols, ByVal lParam)
        
        'See if this Listbox has been logged already...
        lFound = FindHwnd(wParam)
        If lFound Then
            'If it has, update it's "Columns" Extended Property
            uListBoxes(lFound).Columns = sCols
        Else
            'If not, add it and set its Extended Properties
            lLists = lLists + 1
            ReDim Preserve uListBoxes(lLists)
            uListBoxes(lLists).hwnd = wParam
            uListBoxes(lLists).Columns = sCols
        End If
        
    'If we receive our user Defined Message for Setting Checkboxes On/Off...
    Case UD_USECHECKBOXES
        'If this Listbox has been logged, update it's extended property, else add it
        lFound = FindHwnd(wParam)
        If lFound Then
            uListBoxes(lFound).Checkboxes = lParam
        Else
            lLists = lLists + 1
            ReDim Preserve uListBoxes(lLists)
            uListBoxes(lLists).hwnd = wParam
            uListBoxes(lLists).Checkboxes = lParam
        End If
        
    'Draw the Listbox/Listbox Item
    Case WM_DRAWITEM
    
        'This Message only passes the Address of the DrawItem Structure, so we need to
        'use the CopyMemory API to Get a Copy into the Variable we setup:
        Call CopyMemory(tItem, ByVal lParam, Len(tItem))
        
        'Make sure we're dealing with a Listbox
        If tItem.CtlType = ODT_LISTBOX Then

            ReDrawListItem tItem.hwndItem, tItem.hdc, tItem.itemID, tItem.itemState
            
            'Don't Need to Pass a Value on as we've just handled the Message ourselves
            SubClassedList = 0
            Exit Function
                    
        End If
            
    End Select
    
    SubClassedList = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)
End Function

Private Sub ReDrawListItem(ByVal hwnd As Long, ByVal lItemDC As Long, ByVal Index As Long, ByVal lItemState As Long)
    Dim lFound As Long
    Dim sBuff As String * 255
    Dim tItemRect As RECT
    Dim lItemData As Long
    Dim sItemText As String
    Dim lBack As Long
    Dim sValues As Variant
    Dim tRect As RECT
    Dim vCols As Variant
    Dim lCol As Long
    Dim lText As Long
    Dim tORIG As RECT
    Dim lImage As Long
    Dim lDC As Long
    Dim lColor As Long
    Dim lBackColor As Long
    
    Call SendMessage(hwnd, LB_GETITEMRECT, Index, tItemRect)
    Call SendMessage(hwnd, LB_GETITEMRECT, Index, tORIG)
    lItemData = SendMessage(hwnd, LB_GETITEMDATA, Index, ByVal 0&)
    Call SendMessage(hwnd, LB_GETTEXT, Index, ByVal sBuff)
    sItemText = Left(sBuff, InStr(sBuff, Chr(0)) - 1)
                
    lFound = FindHwnd(hwnd)
    
    If (lItemState And ODS_FOCUS) Then
    
        'Item has Focus, Highlight it, I'm using the Default Focus
        'Colors for this example.
        lBack = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
        Call FillRect(lItemDC, tItemRect, lBack)
        Call SetBkColor(lItemDC, GetSysColor(COLOR_HIGHLIGHT))
        Call SetTextColor(lItemDC, GetSysColor(COLOR_HIGHLIGHTTEXT))
    
    Else
    
        'Item Doesn't Have Focus
        'Create a Brush using the Color of the Listbox Window
        lBack = CreateSolidBrush(GetSysColor(COLOR_WINDOW))
        
        'Paint the Item Area
        Call FillRect(lItemDC, tItemRect, lBack)
        
        'Set the Text Colors, using the ForeColor specified in the ItemData of the Item
        Call SetBkColor(lItemDC, GetSysColor(COLOR_WINDOW))
        Call SetTextColor(lItemDC, lItemData)
        
    End If
                
    If lFound Then
    
        'If the Listbox is using Checkboxes, draw them...
        If uListBoxes(lFound).Checkboxes Then
            lBack = CreateSolidBrush(RGB(255, 255, 255))
            tRect.Left = tItemRect.Left + 1
            tRect.Top = tItemRect.Top + 1
            tRect.Bottom = tItemRect.Bottom - 1
            tRect.Right = tItemRect.Left + 16
            Call FillRect(lItemDC, tRect, lBack)
            Call DeleteObject(lBack)
            lImage = LoadBitmap(0&, ByVal OBM_CHECKBOXES)
            lBack = SelectObject(lItemDC, lImage)
            lDC = CreateCompatibleDC(lItemDC)
            Call SelectObject(lDC, lImage)
            BitBlt lItemDC, tItemRect.Left + 1, tItemRect.Top + 1, 12, 12, lDC, 0, 0, SRCCOPY
            Call DeleteDC(lDC)
            Call SelectObject(lItemDC, lBack)
            Call DeleteObject(lImage)
            
            'If the Item is Checked (Selected), Draw the check mark...
            If (lItemState And ODS_SELECTED) Then
                lColor = SetTextColor(lItemDC, GetSysColor(COLOR_WINDOWTEXT))
                lBackColor = SetBkColor(lItemDC, GetSysColor(COLOR_WINDOW))
                lImage = LoadBitmap(0&, ByVal OBM_CHECK)
                lBack = SelectObject(lItemDC, lImage)
                lDC = CreateCompatibleDC(lItemDC)
                Call SelectObject(lDC, lImage)
                BitBlt lItemDC, tItemRect.Left + 2, tItemRect.Top + 1, 12, 12, lDC, 0, 0, SRCAND
                Call DeleteDC(lDC)
                Call SelectObject(lItemDC, lBack)
                Call DeleteObject(lImage)
                Call SetTextColor(lItemDC, lColor)
                Call SetBkColor(lItemDC, lBackColor)
            End If
            tItemRect.Left = tItemRect.Left + 18
        End If
    
        'Display the Item Text
    
        'Split the List Items Text into it's Column Values
        sValues = Split(sItemText, Chr(9))
        
        'Split the column Width String into the Column Width Values
        vCols = Split(uListBoxes(lFound).Columns, ",")
        
        'Output the 1st Item
        sItemText = sValues(0)
        TextOut lItemDC, tItemRect.Left, tItemRect.Top, ByVal sItemText, Len(sItemText)

        'Cycle through any remaining Column Width that have been set
        For lCol = 0 To UBound(vCols)
            If (lCol + 1) <= UBound(sValues) Then
                sItemText = sValues(lCol + 1)
            Else
                sItemText = Space(255)
            End If
            tItemRect.Left = tItemRect.Left + Val(vCols(lCol))
            TextOut lItemDC, tItemRect.Left, tItemRect.Top, ByVal sItemText, Len(sItemText)
        Next
        
        'If there's still column Values and now more columns, append the values to the last Column Added
        If (lCol + 1) <= UBound(sValues) Then
            For lText = (lCol + 1) To UBound(sValues)
                sItemText = sItemText & sValues(lText)
            Next
            TextOut lItemDC, tItemRect.Left, tItemRect.Top, ByVal sItemText, Len(sItemText)
        End If
        
    Else
        'Standard Listbox, just output the Items Text
        TextOut lItemDC, tItemRect.Left, tItemRect.Top, ByVal sItemText, Len(sItemText)
    
    End If

    'If the item is selected (has focus) draw that funky Focus Rectange around the Item
    If (lItemState And ODS_FOCUS) Then DrawFocusRect lItemDC, tORIG
        
    Call DeleteObject(lBack)
End Sub

Public Sub SubLists(ByVal hwnd As Long)
    lPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubClassedList)
End Sub

Public Sub RemoveSubLists(ByVal hwnd As Long)
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWndProc)
End Sub

In the Form:

Private Sub Form_Load()
    Dim lIndex As Long
    
    Randomize Timer
    
    For lIndex = 1 To 10
        'Add Items with 4 columns of data
        List1.AddItem "Row: " & lIndex & Chr(9) & "Column2" & Chr(9) & "Column3" & Chr(9) & "Column4"
        List1.itemData(List1.NewIndex) = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
    Next
    
    'Subclass the "Form", to Capture the Listbox Notification Messages
    SubLists hwnd
    
    'Set the columns Widths for the Listbox (The Last Column needn't be set)
    'Set a Column width to Zero to hide it
    SendMessage hwnd, UD_SETLISTCOLS, List1.hwnd, ByVal "50,50,50"
    
    'Tell the Listbox to use Checkboxes
    SendMessage hwnd, UD_USECHECKBOXES, List1.hwnd, ByVal True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Release the SubClassing, Very Import to Prevent Crashing!
    RemoveSubLists hwnd
End Sub

I originally created this code for making a Listbox Multi-colored so I've left that functionality in too..

To Set the column widths for a Listbox use the UD_SETLISTCOLS Message, i.e.

    SendMessage hwnd, UD_SETLISTCOLS, List1.hwnd, ByVal "50,50,50"

This sets 3 columns each of whom are 50 pixels wide.

To Activate Checkboxes (as the Listbox property Style to be alwasy set to 1), use the UD_USECHECKBOXES message and pass True to Activate them and False to remove them.

To Set an Items color, assign the color value to the ItemData property.

Like I said in the Code, this is a work in progress, just something I've been fiddling with, so it can be streamlined to your specific needs. I also used some VB6 Only functions, like Split, so if you have an earlier version you'll need to write substitue functions (see other posts).

[James Stanich]

I appreciate your help Aaron. That was alot o code to share. Thanks again.