[RESOLVED] ListView item bolding?
I want to be able to make the font bold on particular items/subitems. If the VB6 controls supported the new header visual style, this would be a non-issue (is it possible to do this? Manifests already apply new styles to most other controls); but if push comes to shove, I chose having the new style header as more important, so currently use the 5.0 ListView, but I would like to make an honest effort at this.
I'm just looking for a pointer in the right direction. My ListView is already subclassed to handle various WM_NOTIFY and OCM_NOTIFY messages, and I know how to change the colors with the NMLVCUSTOMDRAW structure; I just don't know how to change the font face or other effects.
Re: ListView item bolding?
version 5 does not support this directly. version 6 has the .ListSubItems collection that allows subitems to have individual boldness, forecolor, & icons. I don't know if APIs can change a version 5 subitem boldness or not; never researched it.
Edited
Since you are subclassing, it is possible to select a different font into the listview hDC (passed as part of the NMCUSTOMDRAW structure. If you go this route:
1) Create a memory font that includes bolding and cache it: CreateFontIndirect API
2) Ensure you change the font for every item in the listview & respond with CDRF_NEWFONT
3) Destroy your cached fonts when project stops subclassing the listview
The downside is that once you start setting fonts for subitems, you will have to do it with all items
Though the sample code isn't VB, I think it is easy to follow & here is that link that discusses your question
Re: ListView item bolding?
Nothing about this is working out... now I can't even set colors.
Code:
Case WM_NOTIFY
Dim tNMH As NMHDR
CopyMemory tNMH, ByVal lParam, Len(tNMH)
Select Case tNMH.code
Case NM_CUSTOMDRAW
Dim nmlvcd As NMLVCUSTOMDRAW
CopyMemory nmlvcd, ByVal lParam, Len(nmlvcd)
With nmlvcd.nmcd
Select Case .dwDrawStage
Case CDDS_PREPAINT
LV2WndProc = CDRF_NOTIFYITEMDRAW
Exit Function
Case CDDS_ITEMPREPAINT Or CDDS_SUBITEM
If .dwItemSpec > 0 Then
'nmlvcd.clrText = vbBlue
nmlvcd.clrTextBk = vbRed
CopyMemory ByVal lParam, nmlvcd, Len(nmlvcd)
If nmlvcd.iSubItem > 1 Then
SelectObject .hdc, hFont
End If
End If
Case CDDS_ITEMPOSTPAINT
LV2WndProc = CDRF_NEWFONT
Exit Function
End Select
LV2WndProc = CDRF_DODEFAULT
End With
End Select
First problem, is setting .clrText or .clrTextBk isn't working. The code is executed (I set breakpoints to check)... but it doesn't raise any errors.
Second issue, when I select the font in, it only applies to the report mode column headers (and randomly turns off and on). But it does display the correct font made from my LOGFONT structure, so that's progress.
It seems only to be processing header items period... since dwItemSpec never exceeds the number of columns regardless of item count. Maybe I should be handling this in the OCM_NOTIFY handler??? :(
Edit again: Sorry I have such a bad habit of yelling at my computer for a half hour, asking people here, then figuring it out myself... using OCM is exactly what I had to do.
Only question right now is how to set the face:
lfFaceName(1 To LF_FACESIZE) As Byte
I tried setting it to a String, but then no matter what I do I can't get it to look like the font in my other, non-owner drawn, ListView.
Code:
Public Sub InitFont()
lfFont.lfWeight = FW_BOLD
lfFont.lfFaceName = "Tahoma" 'Form1.ListView2.Font.name
lfFont.lfHeight = 15 '14 is wrong
lfFont.lfPitchAndFamily = VARIABLE_PITCH Or FF_ROMAN 'FF_DONTCARE and FF_SWISS are wrong
lfFont.lfQuality = PROOF_QUALITY 'CLEARTYPE_QUALITY is wrong
hFont_Bold = CreateFontIndirect(lfFont)
lfFont.lfWeight = FW_NORMAL
hFont_Reg = CreateFontIndirect(lfFont)
End Sub
Re: ListView item bolding?
See this module I made in vase on ucListivew Carles PV
you can change the ForeColor, the BackColor and Font of listItem
Module .Bas
Code:
Option Explicit
Private Declare Function OleTranslateColor Lib "olepro32" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc 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 GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32.dll" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type NMHDR
hwndFrom As Long
idfrom As Long
code As Long
End Type
Private Type NMCUSTOMDRAW
hdr As NMHDR
dwDrawStage As Long
hdc As Long
rc As RECT
dwItemSpec As Long
uItemState As Long
lItemlParam As Long
End Type
Private Type NMLVCUSTOMDRAW
nmcd As NMCUSTOMDRAW
clrText As Long
clrTextBk As Long
iSubItem As Long
End Type
Private Const CDDS_PREPAINT As Long = &H1
Private Const CDDS_POSTPAINT As Long = &H2
Private Const CDDS_PREERASE As Long = &H3
Private Const CDDS_POSTERASE As Long = &H4
Private Const CDDS_ITEM As Long = &H10000
Private Const CDDS_SUBITEM As Long = &H20000
Private Const CDDS_ITEMPREPAINT As Long = (CDDS_ITEM Or CDDS_PREPAINT)
Private Const CDDS_ITEMPOSTPAINT As Long = (CDDS_ITEM Or CDDS_POSTPAINT)
Private Const CDDS_ITEMPREERASE As Long = (CDDS_ITEM Or CDDS_PREERASE)
Private Const CDDS_ITEMPOSTERASE As Long = (CDDS_ITEM Or CDDS_POSTERASE)
Private Const CDRF_DODEFAULT As Long = &H0
Private Const CDRF_NEWFONT As Long = &H2
Private Const CDRF_SKIPDEFAULT As Long = &H4
Private Const CDRF_NOTIFYPOSTPAINT As Long = &H10
Private Const CDRF_NOTIFYITEMDRAW As Long = &H20
Private Const CDRF_NOTIFYPOSTERASE As Long = &H40
Private Const CDRF_NOTIFYSUBITEMDRAW As Long = &H20
Private Const NM_FIRST As Long = 0
Private Const NM_CUSTOMDRAW As Long = (NM_FIRST - 12)
Private Const WM_NOTIFY As Long = &H4E
Private Const GWL_WNDPROC = (-4)
Private uNMH As NMHDR
Public cListView As New Collection
Public cForms As New Collection
Public Sub HookForm(ByVal Frm As Form)
Dim PrevProc As Long
cForms.Add Frm, CStr(Frm.hwnd)
PrevProc = SetWindowLong(Frm.hwnd, GWL_WNDPROC, AddressOf WindowProc)
SetProp Frm.hwnd, "SubClass", PrevProc
End Sub
Public Sub UnHookForm(ByVal Frm As Form)
SetWindowLong Frm.hwnd, GWL_WNDPROC, GetProp(Frm.hwnd, "SubClass")
RemoveProp Frm.hwnd, "SubClass"
cForms.Remove CStr(Frm.hwnd)
End Sub
Private Function IsListView(ByVal hwnd As Long) As Boolean
Dim Item As Variant
For Each Item In cListView
If Item = hwnd Then
IsListView = True
Exit For
End If
Next
End Function
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_NOTIFY Then
Call CopyMemory(uNMH, ByVal lParam, Len(uNMH))
If IsListView(uNMH.hwndFrom) Then
If uNMH.code = NM_CUSTOMDRAW Then
WindowProc = pvCustomDraw(hwnd, uNMH.hwndFrom, lParam)
Exit Function
End If
End If
End If
WindowProc = CallWindowProc(GetProp(hwnd, "SubClass"), hwnd, uMsg, wParam, lParam)
End Function
Private Function pvCustomDraw(ByVal Frmhwnd As Long, ByVal LVhwnd As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim uNMLVCD As NMLVCUSTOMDRAW
Dim bProcess As Boolean
Dim clrTextBk As OLE_COLOR
Dim clrText As OLE_COLOR
Dim oFont As IFont
Call CopyMemory(uNMLVCD, ByVal lParam, Len(uNMLVCD))
With uNMLVCD
Select Case .nmcd.dwDrawStage
Case CDDS_PREPAINT
pvCustomDraw = CDRF_NOTIFYITEMDRAW
Case CDDS_ITEMPREPAINT
pvCustomDraw = CDRF_NOTIFYSUBITEMDRAW
Case CDDS_ITEMPREPAINT Or CDDS_SUBITEM
Call cForms(CStr(Frmhwnd)).OnSubItemPrePaint(LVhwnd, .nmcd.dwItemSpec + 1, .iSubItem, clrTextBk, clrText, oFont, bProcess)
If (bProcess) Then
Call OleTranslateColor(clrTextBk, 0, .clrTextBk)
Call OleTranslateColor(clrText, 0, .clrText)
Call CopyMemory(ByVal lParam, uNMLVCD, Len(uNMLVCD))
End If
If Not oFont Is Nothing Then
SelectObject .nmcd.hdc, oFont.hFont
pvCustomDraw = CDRF_NEWFONT
Else
pvCustomDraw = CDRF_DODEFAULT
End If
End Select
End With
End Function
in Form with the ListView
Code:
Option Explicit
Dim oNewFont As StdFont
Private Sub Form_Load()
Dim i As Long
Dim lvItem As ListItem
Set oNewFont = New StdFont
oNewFont.Bold = True
For i = 1 To 100
Set lvItem = ListView1.ListItems.Add(, , "Item " & i)
lvItem.SubItems(1) = "hola"
lvItem.SubItems(2) = "mundo"
Next
cListView.Add ListView1.hwnd
HookForm Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnHookForm Me
Set oNewFont = Nothing
End Sub
'Esta rutina hay que agregarla en cada formulario que aya que colorear un listview
Public Sub OnSubItemPrePaint(ByVal hwnd As Long, ByVal Item As Long, ByVal SubItem As Long, TextBackColor As Long, TextForeColor As Long, oFont As StdFont, Process As Boolean)
On Error Resume Next
Select Case hwnd
Case ListView1.hwnd
If Item Mod 2 Then
TextBackColor = vbBlue
TextForeColor = vbRed
Set oFont = oNewFont
Process = True
End If
End Select
End Sub
Re: ListView item bolding?
Ok, I've got this going pretty good now; no major issues.
Unless someone sees something wrong with my code, I'll mark this Resolved soon. Thanks guys.
Code:
Public Function LV2WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
[...]
Case OCM_NOTIFY
Dim tNMH As NMHDR
CopyMemory tNMH, ByVal lParam, Len(tNMH)
Select Case tNMH.code
Case NM_CUSTOMDRAW
Dim nmlvcd As NMLVCUSTOMDRAW
CopyMemory nmlvcd, ByVal lParam, Len(nmlvcd)
With nmlvcd.nmcd
Select Case .dwDrawStage
Case CDDS_PREPAINT
LV2WndProc = CDRF_NOTIFYITEMDRAW
Exit Function
Case CDDS_ITEMPREPAINT
LV2WndProc = CDRF_NOTIFYITEMDRAW
Exit Function
Case CDDS_ITEMPREPAINT Or CDDS_SUBITEM
If .dwItemSpec >= 0 Then
Debug.Print "dwItemSpec=" & .dwItemSpec
If (nmlvcd.iSubItem = 1) Then
If IsItemError(.dwItemSpec) Then
nmlvcd.clrText = vbRed
CopyMemory ByVal lParam, nmlvcd, Len(nmlvcd)
Else
nmlvcd.clrText = vbBlack
CopyMemory ByVal lParam, nmlvcd, Len(nmlvcd)
End If
If (IsItemBold(.dwItemSpec)) Then
SelectObject .hdc, hFont_Bold
Else
SelectObject .hdc, hFont_Reg
End If
Else
nmlvcd.clrText = vbBlack
' LV2WndProc = CDRF_DODEFAULT
' Exit Function
CopyMemory ByVal lParam, nmlvcd, Len(nmlvcd)
SelectObject .hdc, hFont_Reg
End If
'Debug.Print "iSubItem=" & nmlvcd.iSubItem
End If
LV2WndProc = CDRF_NOTIFYITEMDRAW
Exit Function
Case CDDS_ITEMPOSTPAINT
LV2WndProc = CDRF_NEWFONT
Exit Function
End Select
LV2WndProc = CDRF_DODEFAULT
End With
End Select
[...]
End Select
LV2WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
End Function
Public Sub InitFont()
lfFont.lfWeight = FW_BOLD
With lfFont 'TAHOMA
.lfFaceName(1) = 84
.lfFaceName(2) = 65
.lfFaceName(3) = 72
.lfFaceName(4) = 79
.lfFaceName(5) = 77
.lfFaceName(6) = 65
End With
lfFont.lfHeight = 13
lfFont.lfCharSet = DEFAULT_CHARSET
lfFont.lfPitchAndFamily = VARIABLE_PITCH Or FF_ROMAN
lfFont.lfQuality = ANTIALIASED_QUALITY
hFont_Bold = CreateFontIndirect(lfFont)
With lfFont
.lfWeight = FW_NORMAL
hFont_Reg = CreateFontIndirect(lfFont)
End With
End Sub
Public Sub DestroyFont()
DeleteObject hFont_Bold
DeleteObject hFont_Reg
End Sub
http://img843.imageshack.us/img843/2764/95791596.jpg
Isn't it pretty? :)