Bold in a List Box

[Janitor]

Can someone let me know how (if possible) to make certain items in a list box appear in bold while others do not. Thanks.

Jay

[Aaron Young]

You can, but you have to use the API's to Subclass the Listbox, ie.

Add a Listbox to your Form and Set the Style to 1 - Graphical, then Add this to a Module..

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 Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex 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 GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long

Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

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

Private Const LB_GETTEXT = &H189
Private Const LB_GETITEMDATA = &H199

Private Const WM_DRAWITEM = &H2B
Private Const GWL_WNDPROC = (-4)

Private Const ODS_FOCUS = &H10
Private Const ODT_LISTBOX = 2

Private lPrevWndProc As Long

Public 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 tTM As TEXTMETRIC
    Dim sBuff As String * 255
    Dim sItem As String
    Dim sFont As String
    Dim lBack As Long
    Dim lFont As Long
    Dim lOld As Long
    
    If Msg = WM_DRAWITEM Then
        'Redraw the listbox
        'This function 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
            'Get the Current Font Dimensions
            Call GetTextMetrics(tItem.hdc, tTM)
            'Get the Font Name
            sFont = Space(255)
            sFont = Left$(sFont, GetTextFace(tItem.hdc, 255, sFont))
            'Create a Font Object, which may be Bold, depending on the ItemData Value
            lFont = CreateFont(tTM.tmHeight, 0, 0, 0, IIf(tItem.itemData, 700, 400), 0, 0, 0, 0, 0, 0, 0, 0, sFont)
            'Select the Font into the Listbox
            lOld = SelectObject(tItem.hdc, lFont)
            'Get the Item 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
                'Item has Focus, Highlight it..
                lBack = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                'Set the Highlight Text Colors
                Call SetBkColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHT))
                Call SetTextColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))
                'Print the Item Text
                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top + 1, ByVal sItem, Len(sItem)
                'Draw the Focus Rectangle around the Item..
                DrawFocusRect tItem.hdc, tItem.rcItem
            Else
                'Normal List Item
                lBack = CreateSolidBrush(GetSysColor(COLOR_WINDOW))
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                Call SetBkColor(tItem.hdc, GetSysColor(COLOR_WINDOW))
                Call SetTextColor(tItem.hdc, GetSysColor(COLOR_WINDOWTEXT))
                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top + 1, ByVal sItem, Len(sItem)
            End If
            Call SelectObject(tItem.hdc, lOld)
            Call DeleteObject(lFont)
            Call DeleteObject(lBack)
            'Don't Need to Pass a Value on as we've just handled the Message ourselves
            SubClassedList = 0
            Exit Function
        End If
    End If
    SubClassedList = CallWindowProc(lPrevWndProc, hWnd, Msg, wParam, lParam)
End Function

Public Sub SubList(ByVal hWnd As Long, Optional ByVal Remove As Boolean = False)
    If Not Remove Then
        lPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubClassedList)
    Else
        Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevWndProc)
    End If
End Sub

Then Add This to the Form Code..

Private Sub Form_Load()
    Dim iIndex As Integer
    Randomize Timer
    For iIndex = 1 To 10
        List1.AddItem "Item " & iIndex
        'Any Item with a NonZero Value for the Item Data will be Bold
        List1.itemData(List1.NewIndex) = (Rnd * 10) Mod 2
    Next
    'Subclass the "Form", to Capture the Listbox Notification Messages
    SubList hWnd
End Sub

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

------------------
Aaron Young
Analyst Programmer
<A HREF="mailto:aarony@redwingso

[1buddylee]

[Nina]

Is it possible to keep the checkboxes?

[Nucleus]

Also consider using a rich text box, which allows many formatting options including bolding of text.