Alternate Color/Zebra Color Untuk Listview Codejock - VB6

Di bawahi ini merupakan module untuk memberi warna-warni (alternate color/zebra color) pada row listview codejock di bawah versi 15.x.x (versi yang belum mendukung property TextBackColor.

Option Explicit 
 
'--------------------------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' Module Alternate Color Listview Codejock untuk versi di bawah 15.x.x 
'--------------------------------------------------------------------------------------------- 
 
Private Const NOERROR = &H0& 
Private Const S_OK = &H0&  
Private Const S_FALSE = &H1& 
Private Const LVM_FIRST = &H1000 
Private Const LVM_SETBKIMAGE = (LVM_FIRST + 68) 
Private Const LVM_SETTEXTBKCOLOR = (LVM_FIRST + 38) 
Private Const LVBKIF_SOURCE_URL = &H2 
Private Const LVBKIF_SOURCE_HBITMAP As Long = &H1 
Private Const LVBKIF_STYLE_TILE = &H10 
Private Const CLR_NONE = &HFFFFFFFF 
  
Private Type LVBKIMAGE 
    ulFlags As Long 
    hbm As Long 
    pszImage As String 
    cchImageMax As Long 
    xOffsetPercent As Long 
    yOffsetPercent As Long 
End Type 
 
Private Declare Sub CoUninitialize Lib "OLE32.DLL" () 
Private Declare Function CoInitialize Lib "OLE32.DLL" (ByVal pvReserved As Long) As Long 
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As  Long, ByVal lParam As Long) 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 LVM_GETITEMRECT As Long = (LVM_FIRST + 14) 
Private Const LVIR_BOUNDS As Long = 0 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Public  Const vbBackColor As Long = &HFCD5C2 
 
'//Ambil satu tinggi listitem codejock untuk dibuat acuan/referensi 
Private Function ListItemHeight(lvw As XtremeSuiteControls.ListView) As Long 
    Dim rc As RECT, i As Long, c As Long, dy As Long 
    c = lvw.ListItems.Count 
    If c = 0 Then Exit Function 
    rc.Left = LVIR_BOUNDS 
    SendMessage lvw.hWnd, LVM_GETITEMRECT, ByVal 0&, rc 
    dy = rc.Bottom - rc.Top  
    ListItemHeight = (dy * Screen.TwipsPerPixelY) 
End Function 
 
'//Bikin dummy picture dari tinggi item codejock yang telah diketahui dari fungsi di atas 
Public Sub SetLvCodeJockTextBKColor(Lv As XtremeSuiteControls.ListView, ByVal BackColorOne As OLE_COLOR, ByVal BackColorTwo As OLE_COLOR, Optional bGradient As Boolean) 
 
    Dim lH As Long 
    Dim lSM As Byte 
    Dim picAlt As PictureBox 
 
    With Lv 
        If .View = xtpListViewReport And .ListItems.Count Then 
            Set picAlt = Lv.Parent.Controls.Add("VB.PictureBox", "picAlt") 
            lSM = .Parent.ScaleMode 
            .Parent.ScaleMode = vbTwips 
            lH = ListItemHeight(Lv) '.ListItems(1).Height 
            With picAlt 
                .BackColor = BackColorOne 
                .AutoRedraw = True 
                 .Height = lH * 2 
                .BorderStyle = 0 
                .Width = 10 * Screen.TwipsPerPixelX 
                If bGradient Then 
                    FadeVertical picAlt, vbWhite, BackColorTwo, lH, lH * 2 
                Else 
                    picAlt.Line (0, lH)-(.ScaleWidth, lH * 2), BackColorTwo, BF 
                End If 
            End With 
            picAlt.Visible = True 
            picAlt.ZOrder 
             Lv.Parent.ScaleMode = lSM 
        End If 
    End With 
 
    SavePicture picAlt.Image, App.Path & "\alternate_color.bmp" 
 
    Lv.Parent.Controls.Remove "picAlt" 
    Set picAlt = Nothing 
    SetBackground Lv 
 
End Sub 
 
'//Jadikan gambar dummy menjadi background listview secara tile (LVBKIF_STYLE_TILE) 
'//Coba hilangkan Constanta LVBKIF_STYLE_TILE, dan lihat apa yang terjadi 
Private Sub SetBackground(lvwTest As XtremeSuiteControls.ListView) 
     Dim sI As String 
    Dim lHDC As Long 
 
    sI = App.Path & "\alternate_color.bmp" 
 
    If (Len(sI) > 0) Then 
        If (InStr(sI, "")) = 0 Then 
            sI = App.Path & "" & sI 
        End If 
        On Error Resume Next 
        If (Dir(sI) <> "") Then 
            If (Err.Number = 0) Then 
                ' Set background - tile 
                Dim tLBI As LVBKIMAGE 
                tLBI.pszImage = sI & Chr$(0) 
                tLBI.cchImageMax = Len(sI) + 1 
                tLBI.ulFlags = LVBKIF_SOURCE_URL Or LVBKIF_STYLE_TILE 
                SendMessage lvwTest.hWnd, LVM_SETBKIMAGE, 0, tLBI 
                'jadikan transparan 
                SendMessageLong lvwTest.hWnd, LVM_SETTEXTBKCOLOR, 0, CLR_NONE 
            Else 
                MsgBox "Error with File '" & sI & "' :" &  Err.Description & ".", vbExclamation 
            End If 
        Else 
            MsgBox "File '" & sI & "' not found.", vbExclamation 
        End If 
    End If 
 
End Sub 
 
'//Membuat warna gradient Start(R,G,B) to End (R,G,B) 
'//FadeVertical picAlt, 255, 255, 255, 266, 233, 216, 0, lH - 20 
Private Sub FadeVertical(ByVal pic As PictureBox, iColorStart As Long, iColorEnd As Long, ByVal start_y, ByVal end_y) 
    Dim start_r As Single, start_g As  Single, start_b As Single 
    Dim end_r As Single, end_g As Single, end_b As Single 
    Dim hgt As Single 
    Dim wid As Single 
    Dim r As Single 
    Dim g As Single 
    Dim b As Single 
    Dim dr As Single 
    Dim dg As Single 
    Dim db As Single 
    Dim Y As Single 
    ColorCodeToRGB iColorEnd, end_r, end_g, end_b 
    ColorCodeToRGB iColorStart, start_r, start_g, start_b 
    wid = pic.ScaleWidth 
    hgt = end_y - start_y 
    dr = (end_r - start_r) / hgt 
    dg = (end_g - start_g) / hgt 
    db = (end_b - start_b) / hgt 
    r = start_r 
    g = start_g 
    b = start_b 
    For Y = start_y To end_y 
        pic.Line (0, Y)-(wid, Y), RGB(r, g, b) 
        r = r + dr 
        g  = g + dg 
        b = b + db 
    Next Y 
End Sub 
 
Public Function ColorCodeToRGB(lColorCode As Long, iRed As Single, iGreen As Single, iBlue As Single) As Boolean 
    Dim lColor As Long 
    lColor = lColorCode      'work long 
    iRed = lColor Mod &H100  'get red component 
    lColor = lColor \ &H100  'divide 
    iGreen = lColor Mod &H100 'get green component 
    lColor = lColor \ &H100  'divide 
    iBlue = lColor Mod &H100 'get blue component 
    ColorCodeToRGB = True 
End Function 

Contoh penggunaan:

SetLvCodeJockTextBKColor lvSuppliers, vbWhite, vbBackColor, True 'True untuk gradient  

Contoh Source Code: http://www.i-bego.com/post32199.html#p32199