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
