[RESOLVED] ListView item bolding?

[fafalone]

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.

[LaVolpe]

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

[fafalone]

Nothing about this is working out... now I can't even set colors.

    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.

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

[LeandroA]

See this module I made in vase on ucListivew Carles PV

you can change the ForeColor, the BackColor and Font of listItem

Module .Bas

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

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

[fafalone]

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.

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

Isn't it pretty?