Contoh Mengisi ListView Dengan Database

Option Explicit

Function FillList(strDomain As String, objListView As Object) As Boolean
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim intTotCount As Integer
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim colNew As ColumnHeader
    Dim itmNewLine As ListItem

    On Error GoTo Err_Handler

    objListView.ListItems.Clear
    objListView.ColumnHeaders.Clear

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(strDomain)

    For intCount1 = 0 To rst.Fields.Count - 1
        Set colNew = objListView.ColumnHeaders.Add(, , rst(intCount1).Name)
    Next intCount1

    objListView.View = 3

    rst.MoveLast
    intTotCount = rst.RecordCount
    rst.MoveFirst

    For intCount1 = 1 To intTotCount
        If IsNumeric(rst(0).Value) Then
            Set itmNewLine = objListView.ListItems.Add(, , Str(rst(0).Value))
        Else
            Set itmNewLine = objListView.ListItems.Add(, , rst(0).Value)
        End If

        For intCount2 = 1 To rst.Fields.Count - 1
            itmNewLine.SubItems(intCount2) = rst(intCount2).Value
        Next intCount2

        rst.MoveNext
    Next intCount1

    Exit Function

Err_Handler:
    If Err = 94 Then
        Resume Next
    Else
        MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    End If
End Function

Private Sub Form_Load()
    Dim intResult As Integer
    intResult = FillList("Employees", Me!ctlListView)
End Sub

READ MORE - Contoh Mengisi ListView Dengan Database

Contoh Mengisi ListView Secara Recursive

Function FirstFileMatch()

    Dim strFileName As String
    On Error Resume Next

    strFileName = Dir(InputBox("Enter a valid path and file name."))
    If strFileName = "" Then
        FirstFileMatch = FirstFileMatch()
    Else
        FirstFileMatch = strFileName
    End If

End Function

Private Sub Form_Load()
    Const strTableQueryName = "Employees"
    Dim db As DAO.Database, rst As DAO.Recordset
    Set db = CurrentDb
    Set rst = db.OpenRecordset(strTableQueryName, dbOpenDynaset, dbReadOnly)
    AddBranch rst:=rst, strPointerField:="ReportsTo", strIDField:="EmployeeID", strTextField:="LastName"
End Sub

Sub AddBranch(rst As Recordset, strPointerField As String, strIDField As String, strTextField As String, Optional varReportToID As Variant)
    On Error GoTo errAddBranch
    Dim nodCurrent As node, objTree As TreeView
    Dim strCriteria As String, strText As String, strKey As String
    Dim nodParent As node, bk As String
    Set objTree = Me!xTree.object
    If IsMissing(varReportToID) Then
        strCriteria = strPointerField & " Is Null"
    Else
        strCriteria = BuildCriteria(strPointerField, rst.Fields(strPointerField).Type, "=" & varReportToID)
        Set nodParent = objTree.Nodes("a" & varReportToID)
    End If

    rst.FindFirst strCriteria
    Do Until rst.NoMatch
        strText = rst(strTextField)
        strKey = "a" & rst(strIDField)
        If Not IsMissing(varReportToID) Then
            Set nodCurrent = objTree.Nodes.Add(nodParent, tvwChild, strKey, strText)
        Else
            Set nodCurrent = objTree.Nodes.Add(, , strKey, strText)
        End If
        bk = rst.Bookmark
        AddBranch rst, strPointerField, strIDField, strTextField, rst(strIDField)
        rst.Bookmark = bk
        rst.FindNext strCriteria
    Loop

exitAddBranch:
    Exit Sub

errAddBranch:
    MsgBox "Can"
    Resume exitAddBranch
End Sub

READ MORE - Contoh Mengisi ListView Secara Recursive

Contoh Mengurutkan ListView Berdasarkan Tanggal

'Kode pada Module
Option Explicit

Public Type POINT
    x As Long
    y As Long
End Type

Public Type LV_FINDINFO
    flags As Long
    psz As String
    lParam As Long
    pt As POINT
    vkDirection As Long
End Type

Public Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    State As Long
    stateMask As Long
    pszText As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

Private Const LVFI_PARAM = 1
Private Const LVIF_TEXT = &H1
Private Const LVM_FIRST = &H1000
Private Const LVM_FINDITEM = LVM_FIRST + 13
Private Const LVM_GETITEMTEXT = LVM_FIRST + 45
Public Const LVM_SORTITEMS = LVM_FIRST + 48

Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Function CompareDates(ByVal lngParam1 As Long, ByVal lngParam2 As Long, ByVal hWnd As Long) As Long

    Dim strName1 As String
    Dim strName2 As String
    Dim dDate1 As Date
    Dim dDate2 As Date

    ListView_GetItemData lngParam1, hWnd, strName1, dDate1
    ListView_GetItemData lngParam2, hWnd, strName2, dDate2

    If dDate1 < dDate2 Then
        CompareDates = 0
    ElseIf dDate1 = dDate2 Then
        CompareDates = 1
    Else
        CompareDates = 2
    End If

End Function

Public Sub ListView_GetItemData(lngParam As Long, hWnd As Long, strName As String, dDate As Date)
    Dim objFind As LV_FINDINFO
    Dim lngIndex As Long
    Dim objItem As LV_ITEM
    Dim baBuffer(32) As Byte
    Dim lngLength As Long

    objFind.flags = LVFI_PARAM
    objFind.lParam = lngParam
    lngIndex = SendMessage(hWnd, LVM_FINDITEM, -1, VarPtr(objFind))

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 0
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    strName = Left$(StrConv(baBuffer, vbUnicode), lngLength)

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 1
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    If lngLength > 0 Then
        dDate = CDate(Left$(StrConv(baBuffer, vbUnicode), lngLength))
    End If

End Sub

Public Sub ListView_GetListItem(lngIndex As Long, hWnd As Long, strName As String, dDate As Date)
    Dim objItem As LV_ITEM
    Dim baBuffer(32) As Byte
    Dim lngLength As Long

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 0
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    strName = Left$(StrConv(baBuffer, vbUnicode), lngLength)

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 1
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    If lngLength > 0 Then
        dDate = CDate(Left$(StrConv(baBuffer, vbUnicode), lngLength))
    End If

End Sub


'Kode pada Form
Option Explicit

Private Sub Form_Load()

    Dim clmAdd As ColumnHeader
    Dim itmAdd As ListItem

    Set clmAdd = ListView1.ColumnHeaders.Add(Text:="Name")
    Set clmAdd = ListView1.ColumnHeaders.Add(Text:="Date")

    ListView1.View = lvwReport

    Set itmAdd = ListView1.ListItems.Add(Text:="Joe")
    itmAdd.SubItems(1) = "05/07/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Sally")
    itmAdd.SubItems(1) = "04/08/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Bill")
    itmAdd.SubItems(1) = "05/29/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Fred")
    itmAdd.SubItems(1) = "05/17/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Anne")
    itmAdd.SubItems(1) = "04/01/97"

End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)

    Dim strName As String
    Dim dDate As Date
    Dim lngItem As Long

    If ColumnHeader.Text = "Name" Then
        ListView1.Sorted = True
        ListView1.SortKey = 0
    Else
        ListView1.Sorted = False
        SendMessage ListView1.hWnd, LVM_SORTITEMS, ListView1.hWnd, AddressOf CompareDates
    End If

    ListView1.Refresh

    For lngItem = 0 To ListView1.ListItems.Count - 1
        ListView_GetListItem lngItem, ListView1.hWnd, strName, dDate
    Next

End Sub

READ MORE - Contoh Mengurutkan ListView Berdasarkan Tanggal

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

READ MORE - Alternate Color/Zebra Color Untuk Listview Codejock - VB6