Comment changer la couleur d'une ligne sur deux dans ma Listview ?
Souvent, pour des questions d'esthétique, ou plus simplement de lisibilité,
il est utile de changer la couleur de fond de certaines lignes de votre liste.
Malheureusement, autant il est possible de changer la couleur d'avant plan au
moyen de la propriété ForeColor de chaque item, autant il n'y a pas de propriété
BackColor.
Avec la version 4.70 de Comctl32.dll, disponible avec Internet Explorer 3 -
voir
Shell and Common Controls Versions pour des informations concernant les
diverses versions -, il est possible d'employer une technique appelée "Custom
Draw". Vous aurez probablement entendu parler des contrôles "owner-drawn" ; le
custom draw permet une certaine flexibilité, voire une flexibilité certaine,
dans le traçage de votre contrôle sans avoir les contraintes imposées par les
contrôles "owner-drawn".
Cette technique, vous l'aurez compris, est celle que nous utiliserons dans
cet article pour changer la couleur de fond. Nous vous signalons par avance,
pour les utilisateurs déçus de ne pas posséder la propriété ForeColor avec les
common controls version 5, que nous montrerons aussi comment
l'implémenter !
ATTENTION ! Nous utilisons du sous classement dans cet exemple. Il est donc
fortement déconseillé d'effectuer un débuggage en pas à pas ou d'appuyer sur les
boutons pause et/ou stop pendant l'exécution. Ceci aura pour effet de planter
Visual Basic. Les modifications non sauvegardée seraient alors perdues. Il est
donc aussi conseillé d'enregistrer très souvent votre travail.
Commençons par créer un module qui nous permettra de sous classer notre form :
Option Explicit
' Déclaration des API
Private Declare Function SetWindowLong _
Lib "user32" _
Alias "SetWindowLongA" _
( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long _
) _
As Long
Public 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 Const GWL_WNDPROC = (-4)
' Variables utilisée par le programme
Private colScControls As New Collection
Public Sub Subclass(hWindow As Long, ObjectToCall As Object, FunctionToCall As
String)
Dim OldWndProc As Long
Dim SCW As CSubclassedWindow
'Si aucun autre contrôle n'est déjà sousclassé
If IsMemberInCollection("hwnd" & hWindow, colScControls) =
False Then
Set SCW = New CSubclassedWindow
Set SCW.ObjectToCall = ObjectToCall
SCW.FunctionToCall = FunctionToCall
SCW.hWnd = hWindow
'Redéfinit la procédure à laquelle
les messages doivent être envoyés
OldWndProc = SetWindowLong(hWindow,
GWL_WNDPROC, AddressOf WndProc)
SCW.OldProc = OldWndProc
'Ajoute l'objet collection
colScControls.Add SCW, "hwnd" &
hWindow
End If
End Sub
' Procédure appelé lorsqu'un nouveau message est à traiter
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
' Booléen permettant de savoir s'il faut retourner la valeur
par défaut ou non
Dim bChangeValue As Boolean, lngNewValue As Long
Dim SCW As CSubclassedWindow
On Error GoTo errhandler
Set SCW = colScControls("hwnd" & hWnd)
If Not SCW Is Nothing Then
Dim MsgCopy As Long, WndCopy As Long,
wParamCopy As Long, lParamCopy As Long
WndCopy = hWnd
MsgCopy = uMsg
wParamCopy = wParam
lParamCopy = lParam
WndProc = CallByName(SCW.ObjectToCall,
SCW.FunctionToCall, VbMethod, WndCopy, MsgCopy, wParamCopy, lParamCopy,
bChangeValue)
' Si on ne veut pas redéfinir la
valeur retournée, on retourne la valeur que retourne la procédure par défaut
If bChangeValue = False Then WndProc
= CallWindowProc(SCW.OldProc, hWnd, uMsg, wParam, lParam)
End If
On Error GoTo 0
errhandler:
If Err.Number Then
Debug.Print "Subclassing error : " &
Err.Description
'On (re)tente de passer le message à
la procédure par défaut
WndProc = CallWindowProc(SCW.OldProc,
hWnd, uMsg, wParam, lParam)
'On tente de désousclasser la fenêtre
posant problème
UnSubclass hWnd
End If
End Function
Public Sub UnSubclass(hWindow As Long)
' Si un contrôle a déjà été souclassé
If IsMemberInCollection("hwnd" & hWindow, colScControls) Then
' Redéfinit la procédure à laquelle
les messages doivent être envoyés
SetWindowLong hWindow, GWL_WNDPROC,
colScControls("hwnd" & hWindow).OldProc
' Supprime la référence à la fenêtre
de la collection
colScControls.Remove "hwnd" & hWindow
End If
End Sub
Public Sub UnSubclassAll()
Dim SCW As CSubclassedWindow
For Each SCW In colScControls
UnSubclass SCW.hWnd
Next SCW
End Sub
Private Function IsMemberInCollection(Member, Collection As Collection) As
Boolean
On Error Resume Next
Collection.Item Member
IsMemberInCollection = (Err.Number = 0)
Err.Clear
End Function
Ce module de sous classement requiert une classe permettant de maintenir
quelques informations à propos d'une fenêtre sous classée. Créez un module de
classe du nom de CSubclassedWindow. Voici son code.
Option Explicit
Public ObjectToCall As Object
Public FunctionToCall As String
Public OldProc As Long
Public hWnd As Long
Maintenant que nous possédons tout ce qu'il faut pour sous
classer, attaquons nous à la partie intéressante du code, celle qui fait changer
la couleur de fond des éléments ajoutés. Créez une nouvelle feuille ou utilisez
une feuille existante. Placez sur cette feuille un Command Button, du nom de
Command1 et un ListView du nom de ListView1. Le code suivant sera utilisé pour
modifier la couleur des éléments.
Option Explicit
Private Const NM_FIRST = &H0& '(0U- 0U)
Private Const NM_CUSTOMDRAW = (NM_FIRST - 12)
Private Const WM_NOTIFY = &H4E
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
Private Const CDRF_NOTIFYPOSTERASE = &H40
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
'Les membres suivants ne sont pas disponibles pour tous les
OS
' iSubItem As Long
' dwItemType As Long
' clrFace As Long
' iIconEffect As Long
' iIconPhase As Long
' iPartId As Long
' iStateId As Long
' rcText As RECT
' uAlign As Long
End Type
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" _
( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Sub Command1_Click()
'On ajoute un élément à la listview
ListView1.ListItems.Add , , "Test"
End Sub
Private Sub Form_Load()
ListView1.View = lvwReport
ListView1.ColumnHeaders.Add , , "Col1"
'Sousclasse la fenêtre
Subclasser.Subclass Me.hWnd, Me, "Subclasser_Message"
'Commentez la ligne suivante
'si vous utilisez la version 5 des common controls
ListView1.FullRowSelect = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Subclasser.UnSubclassAll
End Sub
Public Function Subclasser_Message(ByVal hWnd As Long, ByVal Msg As Long, ByVal
wParam As Long, ByVal lParam As Long, SetNewValue As Boolean) As Long
'On traite en fonction du message reçu
Select Case Msg
'Quand un contrôle notifie son parent
Case WM_NOTIFY
'Ce type de
notifications possèdent toutes une structure commune
Dim Header As
NMHDR
'On copie la
structure à partir de l'adresse offerte
CopyMemory
Header, ByVal lParam, Len(Header)
'On regarde
quel contrôle notifie son parent
Select Case
Header.hwndFrom
'S'il s'agit de notre listview
Case ListView1.hWnd
'On regarde ce qu'il souhaite nous dire
Select Case Header.code
'Il souhaiterait savoir comment il doit effectuer son traçage ?
Case NM_CUSTOMDRAW
'On copie la structure correspondante
'(avant on avait uniquement copié l'en-tête)
Dim LVCust As NMLVCUSTOMDRAW
CopyMemory LVCust, ByVal lParam, Len(LVCust)
'On regarde le niveau de traçage (drawstage)
Select Case LVCust.nmcd.dwDrawStage
'Avant de peindre la liste
Case CDDS_PREPAINT
'On demande une notification de traçage
'pour chaque item de la liste
SetNewValue = True
Subclasser_Message = CDRF_NOTIFYITEMDRAW
'Avant de peindre un élément
Case CDDS_ITEMPREPAINT
'Un item sur deux sera peint en blanc
If LVCust.nmcd.dwItemSpec Mod 2 Then
LVCust.clrTextBk = vbWhite
Else 'l'autre en rouge
LVCust.clrTextBk = &H99FFBD '#BDFF99
End If
'Les common controls v5 n'ont pas ForeColor.
'En décommentant la ligne suivante, vous pourrez changer cette couleur:
'LVCust.clrText = Couleur
'NB : ne fonctionne pas avec la V6, utilisez la propriété ForeColor
End Select
'On recopie la structure modifiée
CopyMemory ByVal lParam, LVCust, Len(LVCust)
End Select
End Select
End Select
End Function |