Bonjour,
Je voudrais savoir si il est possible de mettre une ligne sur deux en
couleurs ( couleur de fond) dans un ListView ?
Autre question, sur un autre listview
Puis-je avoir la première et troisième couleur en vert (couleur de fond)
par
exemple ?
Merci d'avance.
Jean
Bonjour,
Je voudrais savoir si il est possible de mettre une ligne sur deux en
couleurs ( couleur de fond) dans un ListView ?
Autre question, sur un autre listview
Puis-je avoir la première et troisième couleur en vert (couleur de fond)
par
exemple ?
Merci d'avance.
Jean
Bonjour,
Je voudrais savoir si il est possible de mettre une ligne sur deux en
couleurs ( couleur de fond) dans un ListView ?
Autre question, sur un autre listview
Puis-je avoir la première et troisième couleur en vert (couleur de fond)
par
exemple ?
Merci d'avance.
Jean
Bonjour Jean;
Oui, c'est possible, mais il faut utiliser une méthode de subclassing.
Il te faut une version d'Excel supérieure ou égale à 2000 et comme tout
projet utilisant une telle méhode, il faut avant d'exécuter le code la
première fois, compiler le projet pour éliminer les erreurs potentielles
et
enregistrer le projet pour éviter d'avoir à le réécrire car en cas de
plantage, c'est Excel qui plante et oblige à fermer en supprimant le
processus (Crtl + Alt + Sup).
A titre d'exemple et de divertissement, une ligne sur 3 en gras, une ligne
sur 2 en texte rouge sur fond gris:
' Dans ton module UserForm:
Option Explicit
Private Declare Function SetWindowLong& Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Declare Function FindWindow& Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function GetWindow& Lib _
"user32" (ByVal hwnd&, ByVal wCmd&)
Private Declare Function CreateFont& Lib "gdi32" Alias _
"CreateFontA" (ByVal nHeight&, ByVal nWidth&, ByVal nEscapement& _
, ByVal nOrientation&, ByVal fnWeight&, ByVal fdwItalic As Boolean _
, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean _
, ByVal fdwCharSet&, ByVal fdwOutputPrecision& _
, ByVal fdwClipPrecision&, ByVal fdwQuality& _
, ByVal fdwPitchAndFamily&, ByVal lpszFace$)
Private Const GWL_WNDPROC& = (-4&)
Private hwnd&
Private Sub UserForm_Initialize()
Dim i&: i = (ListView1.Width * 1 / 3) - 6
hwnd = GetWindow(FindWindow(vbNullString, Me.Caption), 5)
With ListView1
.View = lvwReport
.FullRowSelect = True
.ColumnHeaders.Add , , "Item Column", i
.ColumnHeaders.Add , , "Subitem 1", i
.ColumnHeaders.Add , , "Subitem 2", i
For i = 0 To 99
With .ListItems.Add(, , "Item " & Format(i, "00"))
.SubItems(1) = "Subitem 1"
.SubItems(2) = "Subitem 2"
End With
Next
End With
hFont = CreateFont(13, 0, 0, 0, 700, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
OldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub
Private Sub UserForm_QueryClose(Cancel%, CloseMode%)
Call SetWindowLong(hwnd, GWL_WNDPROC, OldProc)
End Sub
' Dans un module standard:
Option Explicit
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 RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type NMCUSTOMDRAW
hDR As NMHDR
DrawStage As Long
hDC As Long
R As RECT
ItemSpecs As Long
ItemState As Long
ItemParam As Long
End Type
' Listview customdraw structure
Private Type NMLVCUSTOMDRAW
NMCD As NMCUSTOMDRAW
ForeColorText As Long
BackColorText As Long
End Type
Private Declare Sub RtlMoveMemory Lib "kernel32" _
(lpDest As Any, lpSource As Any, ByVal cBytes&)
Private Declare Function CallWindowProc& Lib "user32" _
Alias "CallWindowProcA" (ByVal lpPrevWndFunc& _
, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Private Declare Function SelectObject& Lib _
"gdi32" (ByVal hDC&, ByVal hObject&)
Public hFont&, OldProc&
Function WinProc&(ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Select Case Msg
Case &H4E ' (WM_NOTIFY)
Dim UDT1 As NMHDR
RtlMoveMemory UDT1, ByVal lParam, 12&
If UDT1.Code = -12 Then ' (NM_CUSTOMDRAW)
Dim UDT2 As NMLVCUSTOMDRAW
RtlMoveMemory UDT2, ByVal lParam, Len(UDT2)
With UDT2.NMCD
Select Case .DrawStage
Case &H1: WinProc = &H20: Exit Function
Case &H10001
' Set listview font item.
If (.ItemSpecs Mod 3) = 0 Then SelectObject .hDC, hFont
' Set listview forecolor & backcolor item.
If (.ItemSpecs Mod 2) = 0 Then
UDT2.ForeColorText = vbRed
UDT2.BackColorText = &HC0C0C0
RtlMoveMemory ByVal lParam, UDT2, Len(UDT2)
End If
WinProc = &H2: Exit Function
End Select
End With
End If
End Select
WinProc = CallWindowProc(OldProc, hwnd, Msg, wParam, lParam)
End Function
Sub CustomListView()
UserForm1.Show
End Sub
MP
"Jean" a écrit dans le message de news:
43f8c368$0$20179$Bonjour,
Je voudrais savoir si il est possible de mettre une ligne sur deux en
couleurs ( couleur de fond) dans un ListView ?
Autre question, sur un autre listview
Puis-je avoir la première et troisième couleur en vert (couleur de fond)
parexemple ?
Merci d'avance.
Jean
Bonjour Jean;
Oui, c'est possible, mais il faut utiliser une méthode de subclassing.
Il te faut une version d'Excel supérieure ou égale à 2000 et comme tout
projet utilisant une telle méhode, il faut avant d'exécuter le code la
première fois, compiler le projet pour éliminer les erreurs potentielles
et
enregistrer le projet pour éviter d'avoir à le réécrire car en cas de
plantage, c'est Excel qui plante et oblige à fermer en supprimant le
processus (Crtl + Alt + Sup).
A titre d'exemple et de divertissement, une ligne sur 3 en gras, une ligne
sur 2 en texte rouge sur fond gris:
' Dans ton module UserForm:
Option Explicit
Private Declare Function SetWindowLong& Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Declare Function FindWindow& Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function GetWindow& Lib _
"user32" (ByVal hwnd&, ByVal wCmd&)
Private Declare Function CreateFont& Lib "gdi32" Alias _
"CreateFontA" (ByVal nHeight&, ByVal nWidth&, ByVal nEscapement& _
, ByVal nOrientation&, ByVal fnWeight&, ByVal fdwItalic As Boolean _
, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean _
, ByVal fdwCharSet&, ByVal fdwOutputPrecision& _
, ByVal fdwClipPrecision&, ByVal fdwQuality& _
, ByVal fdwPitchAndFamily&, ByVal lpszFace$)
Private Const GWL_WNDPROC& = (-4&)
Private hwnd&
Private Sub UserForm_Initialize()
Dim i&: i = (ListView1.Width * 1 / 3) - 6
hwnd = GetWindow(FindWindow(vbNullString, Me.Caption), 5)
With ListView1
.View = lvwReport
.FullRowSelect = True
.ColumnHeaders.Add , , "Item Column", i
.ColumnHeaders.Add , , "Subitem 1", i
.ColumnHeaders.Add , , "Subitem 2", i
For i = 0 To 99
With .ListItems.Add(, , "Item " & Format(i, "00"))
.SubItems(1) = "Subitem 1"
.SubItems(2) = "Subitem 2"
End With
Next
End With
hFont = CreateFont(13, 0, 0, 0, 700, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
OldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub
Private Sub UserForm_QueryClose(Cancel%, CloseMode%)
Call SetWindowLong(hwnd, GWL_WNDPROC, OldProc)
End Sub
' Dans un module standard:
Option Explicit
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 RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type NMCUSTOMDRAW
hDR As NMHDR
DrawStage As Long
hDC As Long
R As RECT
ItemSpecs As Long
ItemState As Long
ItemParam As Long
End Type
' Listview customdraw structure
Private Type NMLVCUSTOMDRAW
NMCD As NMCUSTOMDRAW
ForeColorText As Long
BackColorText As Long
End Type
Private Declare Sub RtlMoveMemory Lib "kernel32" _
(lpDest As Any, lpSource As Any, ByVal cBytes&)
Private Declare Function CallWindowProc& Lib "user32" _
Alias "CallWindowProcA" (ByVal lpPrevWndFunc& _
, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Private Declare Function SelectObject& Lib _
"gdi32" (ByVal hDC&, ByVal hObject&)
Public hFont&, OldProc&
Function WinProc&(ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Select Case Msg
Case &H4E ' (WM_NOTIFY)
Dim UDT1 As NMHDR
RtlMoveMemory UDT1, ByVal lParam, 12&
If UDT1.Code = -12 Then ' (NM_CUSTOMDRAW)
Dim UDT2 As NMLVCUSTOMDRAW
RtlMoveMemory UDT2, ByVal lParam, Len(UDT2)
With UDT2.NMCD
Select Case .DrawStage
Case &H1: WinProc = &H20: Exit Function
Case &H10001
' Set listview font item.
If (.ItemSpecs Mod 3) = 0 Then SelectObject .hDC, hFont
' Set listview forecolor & backcolor item.
If (.ItemSpecs Mod 2) = 0 Then
UDT2.ForeColorText = vbRed
UDT2.BackColorText = &HC0C0C0
RtlMoveMemory ByVal lParam, UDT2, Len(UDT2)
End If
WinProc = &H2: Exit Function
End Select
End With
End If
End Select
WinProc = CallWindowProc(OldProc, hwnd, Msg, wParam, lParam)
End Function
Sub CustomListView()
UserForm1.Show
End Sub
MP
"Jean" <jj@free.fr> a écrit dans le message de news:
43f8c368$0$20179$8fcfb975@news.wanadoo.fr...
Bonjour,
Je voudrais savoir si il est possible de mettre une ligne sur deux en
couleurs ( couleur de fond) dans un ListView ?
Autre question, sur un autre listview
Puis-je avoir la première et troisième couleur en vert (couleur de fond)
par
exemple ?
Merci d'avance.
Jean
Bonjour Jean;
Oui, c'est possible, mais il faut utiliser une méthode de subclassing.
Il te faut une version d'Excel supérieure ou égale à 2000 et comme tout
projet utilisant une telle méhode, il faut avant d'exécuter le code la
première fois, compiler le projet pour éliminer les erreurs potentielles
et
enregistrer le projet pour éviter d'avoir à le réécrire car en cas de
plantage, c'est Excel qui plante et oblige à fermer en supprimant le
processus (Crtl + Alt + Sup).
A titre d'exemple et de divertissement, une ligne sur 3 en gras, une ligne
sur 2 en texte rouge sur fond gris:
' Dans ton module UserForm:
Option Explicit
Private Declare Function SetWindowLong& Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Declare Function FindWindow& Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function GetWindow& Lib _
"user32" (ByVal hwnd&, ByVal wCmd&)
Private Declare Function CreateFont& Lib "gdi32" Alias _
"CreateFontA" (ByVal nHeight&, ByVal nWidth&, ByVal nEscapement& _
, ByVal nOrientation&, ByVal fnWeight&, ByVal fdwItalic As Boolean _
, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean _
, ByVal fdwCharSet&, ByVal fdwOutputPrecision& _
, ByVal fdwClipPrecision&, ByVal fdwQuality& _
, ByVal fdwPitchAndFamily&, ByVal lpszFace$)
Private Const GWL_WNDPROC& = (-4&)
Private hwnd&
Private Sub UserForm_Initialize()
Dim i&: i = (ListView1.Width * 1 / 3) - 6
hwnd = GetWindow(FindWindow(vbNullString, Me.Caption), 5)
With ListView1
.View = lvwReport
.FullRowSelect = True
.ColumnHeaders.Add , , "Item Column", i
.ColumnHeaders.Add , , "Subitem 1", i
.ColumnHeaders.Add , , "Subitem 2", i
For i = 0 To 99
With .ListItems.Add(, , "Item " & Format(i, "00"))
.SubItems(1) = "Subitem 1"
.SubItems(2) = "Subitem 2"
End With
Next
End With
hFont = CreateFont(13, 0, 0, 0, 700, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
OldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub
Private Sub UserForm_QueryClose(Cancel%, CloseMode%)
Call SetWindowLong(hwnd, GWL_WNDPROC, OldProc)
End Sub
' Dans un module standard:
Option Explicit
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 RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type NMCUSTOMDRAW
hDR As NMHDR
DrawStage As Long
hDC As Long
R As RECT
ItemSpecs As Long
ItemState As Long
ItemParam As Long
End Type
' Listview customdraw structure
Private Type NMLVCUSTOMDRAW
NMCD As NMCUSTOMDRAW
ForeColorText As Long
BackColorText As Long
End Type
Private Declare Sub RtlMoveMemory Lib "kernel32" _
(lpDest As Any, lpSource As Any, ByVal cBytes&)
Private Declare Function CallWindowProc& Lib "user32" _
Alias "CallWindowProcA" (ByVal lpPrevWndFunc& _
, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Private Declare Function SelectObject& Lib _
"gdi32" (ByVal hDC&, ByVal hObject&)
Public hFont&, OldProc&
Function WinProc&(ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
Select Case Msg
Case &H4E ' (WM_NOTIFY)
Dim UDT1 As NMHDR
RtlMoveMemory UDT1, ByVal lParam, 12&
If UDT1.Code = -12 Then ' (NM_CUSTOMDRAW)
Dim UDT2 As NMLVCUSTOMDRAW
RtlMoveMemory UDT2, ByVal lParam, Len(UDT2)
With UDT2.NMCD
Select Case .DrawStage
Case &H1: WinProc = &H20: Exit Function
Case &H10001
' Set listview font item.
If (.ItemSpecs Mod 3) = 0 Then SelectObject .hDC, hFont
' Set listview forecolor & backcolor item.
If (.ItemSpecs Mod 2) = 0 Then
UDT2.ForeColorText = vbRed
UDT2.BackColorText = &HC0C0C0
RtlMoveMemory ByVal lParam, UDT2, Len(UDT2)
End If
WinProc = &H2: Exit Function
End Select
End With
End If
End Select
WinProc = CallWindowProc(OldProc, hwnd, Msg, wParam, lParam)
End Function
Sub CustomListView()
UserForm1.Show
End Sub
MP
"Jean" a écrit dans le message de news:
43f8c368$0$20179$Bonjour,
Je voudrais savoir si il est possible de mettre une ligne sur deux en
couleurs ( couleur de fond) dans un ListView ?
Autre question, sur un autre listview
Puis-je avoir la première et troisième couleur en vert (couleur de fond)
parexemple ?
Merci d'avance.
Jean
