LVColouredItems

Option Explicit
'

' Custom Draw Message to intercept

'

Public Enum WinNotifications
NM_FIRST = -0& ' (0U- 0U) ' // generic to all controls
NM_LAST = -99& ' (0U- 99U)
NM_OUTOFMEMORY = (NM_FIRST - 1)
NM_CLICK = (NM_FIRST - 2)
NM_DBLCLK = (NM_FIRST - 3)
NM_RETURN = (NM_FIRST - 4)
NM_RCLICK = (NM_FIRST - 5)
NM_RDBLCLK = (NM_FIRST - 6)
NM_SETFOCUS = (NM_FIRST - 7)
NM_KILLFOCUS = (NM_FIRST - 8)
NM_CUSTOMDRAW = (NM_FIRST - 12)
NM_HOVER = (NM_FIRST - 13)
End Enum
'

' Win API Rect structure

'

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

' Custom Draw Structures

'

' The NMHDR structure contains information about a notification message. The pointer

' to this structure is specified as the lParam member of the WM_NOTIFY message.

'

Private Type NMHDR
hwndFrom As Long ' Window handle of control sending message
idFrom As Long ' Identifier of control sending message
code As Long ' Specifies the notification code
End Type
Private Type NMCUSTOMDRAWINFO
hdr As NMHDR
dwDrawStage As Long
hdc As Long
rc As RECT
dwItemSpec As Long
iItemState As Long
lItemLParam As Long
End Type
Private Type NMLVCUSTOMDRAW
nmcmd As NMCUSTOMDRAWINFO
clrText As Long
clrTextBk As Long
iSubItem As Integer
End Type
'

' Notify Message

'

Private Const WM_NOTIFY& = &H4E
'

' Custom Draw Messages

'

Private Const CDDS_PREPAINT& = &H1
Private Const CDDS_POSTPAINT& = &H2
Private Const CDDS_PREERASE& = &H3
Private Const CDDS_POSTERASE& = &H4
Private Const CDDS_ITEM& = &H10000
Private Const CDDS_ITEMPREPAINT& = CDDS_ITEM Or CDDS_PREPAINT
Private Const CDDS_ITEMPOSTPAINT& = CDDS_ITEM Or CDDS_POSTPAINT
Private Const CDDS_ITEMPREERASE& = CDDS_ITEM Or CDDS_PREERASE
Private Const CDDS_ITEMPOSTERASE& = CDDS_ITEM Or CDDS_POSTERASE
Private Const CDDS_SUBITEM& = &H20000
Private Const CDRF_DODEFAULT& = &H0
Private Const CDRF_NEWFONT& = &H2
Private Const CDRF_SKIPDEFAULT& = &H4
Private Const CDRF_NOTIFYPOSTPAINT& = &H10
Private Const CDRF_NOTIFYITEMDRAW& = &H20
Private Const CDRF_NOTIFYSUBITEMDRAW = &H20 ' flags are the same, we can distinguish by context
Private Const CDRF_NOTIFYPOSTERASE& = &H40
Private Const CDRF_NOTIFYITEMERASE& = &H80
'

' Win API Declarations

'

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength 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 Const WM_GETFONT = &H31
Private Sub Form_Load()
Dim li As ListItem
Dim lCount As Long
'

' Setup the listview with 1 column and 25 listitems

'

With ListView1.ListItems
ListView1.ColumnHeaders.Add 1, "Test", "Column 1"
For lCount = 1 To 25
Set li = .Add(lCount, "key" & lCount, "This Is Line " & lCount)
Next
End With
'

' Now subclass the form and watch for WM_NOTIFY messages coming from the listview

'

' I'm using the Softcircuits subclass control here, although you can use any other

' (they all work in pretty much the same way). You could also do any AddressOf processing

' if you so wish. I just use the SC control because it's a lot quicker (and you don't have

' to remember to un-subclass your window afterwards)

'

With Subclass1
.hwnd = Me.hwnd
.Messages(WM_NOTIFY) = True
End With
End Sub
'_________________________________________________________


Private Sub Subclass1_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
Dim tMessage As NMHDR
Dim lCode As Long
Dim tLVRedrawMessage As NMLVCUSTOMDRAW
Select Case Msg
'

' Should only be WM_NOTIFY (that's all we've subclassed)

'

Case WM_NOTIFY
'

' Same as in C : tMessage = (NMHDR) lParam;

'

'

' The .code section of the NMHDR notify structure contains the submessage

'

CopyMemory tMessage, ByVal lParam, Len(tMessage)
lCode = tMessage.code
Select Case lCode
Case NM_CUSTOMDRAW
'

' Make sure it's our listview raising the Custom Redraw message

'

If tMessage.hwndFrom <> ListView1.hwnd Then
'

' It's not ! - Return default processing to windows

'

Result = Subclass1.CallWndProc(Msg, wParam, lParam)
Exit Sub
End If
'

' Copy the message into our local structure

'

CopyMemory tLVRedrawMessage, ByVal lParam, Len(tLVRedrawMessage)
'

' Now process the Custom Redraw Messages in Order :

'

' CDDS_PREPAINT is at the beginning of the paint cycle.

' You must return the property value to get Custom painting

' to work correctly. In this example, we're only looking for

' item specific painting - although theoretically, you should

' be able to paint just about anything on the control, from

' bitmap backgrounds to changing fonts etc.

'

' (Just don't ask me how to do it (yet)).

'

If tLVRedrawMessage.nmcmd.dwDrawStage = CDDS_PREPAINT Then
'

' Request a notification for each item being painted

'

Result = CDRF_NOTIFYITEMDRAW
Exit Sub
End If
'

' Because we returned CDRF_NOTIFYITEMDRAW in the above code, CDDS_ITEMPREPAINT is now sent

' when the control is ready to paint an Item

'

If tLVRedrawMessage.nmcmd.dwDrawStage = CDDS_ITEMPREPAINT Then
'

' The item's about to be repainted - Here's where you can trap to see which item is being

' painted and so set the color accordingly

'

' To see which item is about to be painted, check :

'

' if tLVRedrawMessage.nmcm.dwItemSpec = required listview item number Then

'

' To Change the text and background colours in a list view control,

' set the clrText and clrTextBk members of the NMLVCUSTOMDRAW structure to the

' required color. Most other controls rely on the SetTextColor and SetBkColor API

' calls on the passed in hdc

'

' In this code I'm setting every second listitem to be red

'

'

With tLVRedrawMessage
If .nmcmd.dwItemSpec / 2 = CInt(.nmcmd.dwItemSpec / 2) Then
.clrTextBk = vbWhite
.clrText = vbRed
'

' You must remember to copy back the changes made in tLVRedrawMessage to the LPARAM value

'

CopyMemory ByVal lParam, tLVRedrawMessage, Len(tLVRedrawMessage)
Exit Sub
Else
'

' This is standard painting stuff - let windows do it for us

'

Result = CDRF_DODEFAULT
Exit Sub
End If
End With
End If
Case Else
'

' Other messages from the listview which we're not interested in should be passed back

'

Result = Subclass1.CallWndProc(Msg, wParam, lParam)
Exit Sub
End Select
End Select
End Sub