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
Printable View
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
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..
Then Add This to the Form Code..Code: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
------------------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
Is it possible to keep the checkboxes?
Also consider using a rich text box, which allows many formatting options including bolding of text.