Hi apol
Here is the code from the second link:
'====bas module code=====
Option Explicit
Public Const NM_CUSTOMDRAW = (-12&)
Public Const WM_NOTIFY As Long = &H4E&
Public Const CDDS_PREPAINT As Long = &H1&
Public Const CDRF_NOTIFYITEMDRAW As Long = &H20&
Public Const CDDS_ITEM As Long = &H10000
Public Const CDDS_ITEMPREPAINT As Long = CDDS_ITEM Or CDDS_PREPAINT
Public Const CDRF_NEWFONT As Long = &H2&
Public 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
' sub struct of the NMCUSTOMDRAW struct
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' generic customdraw struct
Public 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
' listview specific customdraw struct
Public Type NMLVCUSTOMDRAW
nmcd As NMCUSTOMDRAW
clrText As Long
clrTextBk As Long
' if IE >= 4.0 this member of the struct can be used
'iSubItem As Integer
End Type
Public g_addProcOld As Long
Public g_MaxItems As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes&)
Public Declare Function CallWindowProc& Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc&, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Public Function WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_NOTIFY
Dim udtNMHDR As NMHDR
CopyMemory udtNMHDR, ByVal lParam, 12&
With udtNMHDR
If .code = NM_CUSTOMDRAW Then
Dim udtNMLVCUSTOMDRAW As NMLVCUSTOMDRAW
CopyMemory udtNMLVCUSTOMDRAW, ByVal lParam, Len(udtNMLVCUSTOMDRAW)
With udtNMLVCUSTOMDRAW.nmcd
Select Case .dwDrawStage
Case CDDS_PREPAINT
WindowProc = CDRF_NOTIFYITEMDRAW
Exit Function
Case CDDS_ITEMPREPAINT
If Val(Form1.ListView1.ListItems(.dwItemSpec + 1).Index) = 3 Then
udtNMLVCUSTOMDRAW.clrText = vbRed
Else
udtNMLVCUSTOMDRAW.clrText = vbBlack
End If
'You may also change BackColor same way:
' udtNMLVCUSTOMDRAW.clrTextBk = Val(Form1.ListView1.ListItems(.dwItemSpec + 1).Tag)
CopyMemory ByVal lParam, udtNMLVCUSTOMDRAW, Len(udtNMLVCUSTOMDRAW)
WindowProc = CDRF_NEWFONT
Exit Function
End Select
End With
End If
End With
End Select
WindowProc = CallWindowProc(g_addProcOld, hwnd, iMsg, wParam, lParam)
End Function
'=======Form code=======
Option Explicit
Private Const GWL_WNDPROC As Long = (-4&)
Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Sub Form_Load()
With ListView1
.FullRowSelect = True
.ColumnHeaders.Add , , "Item Column"
.ColumnHeaders.Add , , "Subitem 1"
.ColumnHeaders.Add , , "Subitem 2"
Dim i&
For i = 1 To 30
With .ListItems.Add(, , CStr(Int(200 * Rnd)))
.SubItems(1) = "Subitem 1"
.SubItems(2) = "Subitem 2"
'I used Tag property to set back color
.Tag = CStr(QBColor(i Mod 15))
End With
Next
.ListItems(20).ForeColor = vbBlue
g_MaxItems = .ListItems.Count - 1
End With
g_addProcOld = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call SetWindowLong(hwnd, GWL_WNDPROC, g_addProcOld)
End Sub
'Note: This code use subclassing. So, don't stop it from IDE stop button, use form [x] button instead
This code is not tested; remove the red line from the code it's only for test
Regards
DoctorMahdi
No one has replied yet! Why not be the first?
Sign in or Join us (it's free).