LISTVIEW ZEBRADO...

USUARIO.EXCLUIDOS 16/03/2004 12:02:20
#15580 Resposta escolhida

Existem duas formas de se fazer isto, 1 usando 1 picture zebrado como fundo a outra usando subclassing, vou postar um exemplo de cada:

Crie um projeto com 1picturebox, 1listView e 1ImageList, cole este código:

Private Sub Form_Load()

Dim I As Long
Dim LI As ListItem
Dim ICO As Long

With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "Coluna 1"
.ColumnHeaders.Add , , "Coluna 2"
.ColumnHeaders.Add , , "Coluna 3"
.View = lvwReport
.SmallIcons = ImageList1
.FullRowSelect = True
End With

Randomize Timer

For I = 1 To 5
ICO = Fix(Rnd * ImageList1.ListImages.Count) + 1
Set LI = Form1.ListView1.ListItems.Add(, , "Info Principal", , ICO)
LI.SubItems(1) = "Info Col 2"
LI.SubItems(2) = "Info Col 3"
Next

If LVZebra(ListView1, Picture1, vbWhite, RGB(192, 192, 192)) = False Then
MsgBox "Não foi possível criar as listras", vbCritical
End If


End Sub


Function LVZebra(LV As ListView, Pic As PictureBox, Cor1 As Long, Cor2 As Long) As Boolean

' A idéia é simples, basta criar o zebrado como uma imagem
' num picturebox e coloca-la como imagem de fundo no listview

Dim lHght As Long
Dim lWdth As Long

LVZebra = False

' Só proceda se o listview estiver em modo
' report e com pelo menos 1 linha
If LV.View lvwReport Then Exit Function
If LV.ListItems.Count = 0 Then Exit Function

' Prepara o listview
With LV
.Picture = Nothing
.Refresh
.Visible = True
.PictureAlignment = lvwTile
' Pega o comprimento
lWdth = .Width
End With

' Prepara o picturebox
With Pic
' Apaga o que tiver nele (caso a gente precise chamar a função de novo)
.AutoRedraw = False
.Picture = Nothing
.BackColor = vbWhite
.Height = 1
.AutoRedraw = True
.BorderStyle = vbBSNone
.ScaleMode = vbTwips
' Joga para fora do form
.Top = Form1.Top - 10000
.Width = Screen.Width
.Visible = False
.Font = LV.Font

' Iguala as propriedades de fonte do picturebox com o listview
With .Font
.Bold = LV.Font.Bold
.Charset = LV.Font.Charset
.Italic = LV.Font.Italic
.Name = LV.Font.Name
.Strikethrough = LV.Font.Strikethrough
.Underline = LV.Font.Underline
.Weight = LV.Font.Weight
.Size = LV.Font.Size
End With

' Pega a altura do primeiro item
lHght = LV.ListItems(1).Height

' Ajusta a altura e largura do picturebox
.Height = lHght * 2
.Width = lWdth

' Desenha as 2 linhas, uma de cada cor
Pic.Line (0, 0)-(lWdth, lHght), Cor1, BF
Pic.Line (0, lHght)-(lWdth, (lHght * 2)), Cor2, BF
.AutoSize = True
.Refresh

End With

' Insere no listview
LV.Refresh
LV.Picture = Pic.Image
' Sucesso
LVZebra = True

End Function



Agora se quiser fazer usando subClassing:

'No modulo:
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
idFrom As Long
code As Long
End Type

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

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

Public Type NMLVCUSTOMDRAW
nmcd As NMCUSTOMDRAW
clrText As Long
clrTextBk As Long
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).Text) = 100 Then
udtNMLVCUSTOMDRAW.clrText = vbBlack
Else
udtNMLVCUSTOMDRAW.clrText = vbRed
End If
'I used Listitem.Tag Property To Set color, though you can use Text etc.
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


'No form
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
.View = lvwReport
.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"
.Tag = QBColor(15)
If i Mod 2 Then .Tag = CStr(vbBlack) 'CStr(QBColor(14))
End With
Next
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