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

Software Kamus Bahasa Inggriis Freeware 1.0

Ini merupakan aplikasi kamus bahasa inggris versi pertama, kosakatanya belum begitu banyak hanya ada sekitar 23 ribuan. Merupakan pengembangan dari cara membuat kamus bahasa inggris yang telah dijelaskan secara panjang lebar. Kelebihan dan kekurangannya bisa Anda lihat pada link tersebut.

Download: Kamus Bahasa Inggris Freeware 1.0

READ MORE - Software Kamus Bahasa Inggriis Freeware 1.0

ComboBox Class - Mempermudah Pembuatan Aplikasi VB6

Option Explicit 
 
Private WithEvents cbo As ComboBox 
Public AutoDropDown As Boolean 
 
Private Type POINTAPI 
    x As Long 
    y As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
'API Declarations 
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long 
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) 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 Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) 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 
 
'Contanta 
Private Const CB_GETITEMHEIGHT As Long = &H154 
Private Const CB_SHOWDROPDOWN As Long = &H14F 
Private Const CB_FINDSTRING = &H14C 
Private Const CB_SETDROPPEDWIDTH = &H160 
Private Const CB_FINDSTRINGEXACT As Long = &H158 
Private Const CB_SELECTSTRING As Long = &H14D 
 
Private Const EC_LEFTMARGIN = &H1 
Private Const EC_RIGHTMARGIN = &H2 
Private Const EC_USEFONTINFO = &HFFFF& 
Private Const EM_SETMARGINS = &HD3& 
Private Const EM_GETMARGINS = &HD4& 
 
Public Sub ChangeComboDropDownHeight(Optional ItemToDisplay As Integer = 10) 
 
    Dim pt As POINTAPI 
    Dim rc As RECT 
    Dim cWidth As Long 
    Dim newHeight As Long 
    Dim oldScaleMode As Long 
    Dim numItemsToDisplay As Long 
    Dim itemHeight As Long 
 
    numItemsToDisplay = ItemToDisplay 
 
    oldScaleMode = cbo.Parent.ScaleMode 
    cbo.Parent.ScaleMode = vbPixels 
    cWidth = cbo.Width 
 
    itemHeight = SendMessage(cbo.hwnd, CB_GETITEMHEIGHT, 0, ByVal 0) 
    newHeight = itemHeight * (numItemsToDisplay + 2) 
    Call GetWindowRect(cbo.hwnd, rc) 
 
    pt.x = rc.Left 
    pt.y = rc.Top 
 
    Call ScreenToClient(cbo.Parent.hwnd, pt) 
    Call MoveWindow(cbo.hwnd, pt.x, pt.y, cbo.Width, newHeight, True) 
    cbo.Parent.ScaleMode = oldScaleMode 
 
End Sub 
 
Public Property Let ComboBox(New_ComboBox As ComboBox) 
    Set cbo = New_ComboBox 
End Property 
 
Public Sub ShowDropDown() 
    If cbo.ListCount > 0 Then 
        SendMessage cbo.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0& 
    End If 
End Sub 
 
Private Sub cbo_GotFocus() 
    If Not AutoDropDown Then Exit Sub 
    Dim ret As Long 
    ret = SendMessage(cbo.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&) 
End Sub 
 
Public Sub SetDropWidth(lngWidth As Long) 
    SendMessageLong cbo.hwnd, CB_SETDROPPEDWIDTH, lngWidth, 0 
End Sub 
 
Public Function GetEditHwnd() As Long 
    GetEditHwnd = FindWindowEx(cbo.hwnd, 0, "EDIT", vbNullString) 
End Function 
 
Public Function Find(FindText As String, Optional SetTopIndex As Boolean) As Boolean 
    Dim ret As Long 
    ret = SendMessage(cbo.hwnd, CB_FINDSTRING, -1, ByVal FindText) 
    If ret > -1 Then 
        Find = True 
        If SetTopIndex Then 
            cbo.TopIndex = ret 
            cbo.ListIndex = ret 
        Else 
            cbo.ListIndex = ret 
        End If 
    End If 
End Function 
 
Public Function FindExact(ByVal SearchString As String, Optional ByVal StartFrom As Long = -1) As Long 
    FindExact = SendMessage(cbo.hwnd, CB_FINDSTRINGEXACT, StartFrom, ByVal SearchString) 
End Function 
 
Public Function FindSelect(ByVal SearchString As String, Optional ByVal StartFrom As Long = -1) As Long 
    FindSelect = SendMessage(cbo.hwnd, CB_SELECTSTRING, StartFrom, ByVal SearchString) 
End Function 
 
Public Sub DisableScroll() 
    Call pUnSubClassCombo(cbo) 
    glPrevWndProcC = fSubClassCombo(cbo) 
End Sub 
 
Private Sub Class_Terminate() 
    Call pUnSubClassCombo(cbo) 
End Sub 

READ MORE - ComboBox Class - Mempermudah Pembuatan Aplikasi VB6

ComboBox SubClassing - Private Collections

Option Explicit 
 
 
Public glPrevWndProc As Long 
Public glPrevWndProcC As Long 
 
Private Const GWL_WNDPROC = (-4) 
Private Const WM_RBUTTONUP = &H205 
Private Const WM_RBUTTONDOWN = &H204 
Private Const WM_PARENTNOTIFY = &H210 
Private Const WM_MOUSEMOVE = &H200 
Private Const WM_MOUSEWHEEL As Long = &H20A 
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
 
'ComboBox 
Public Sub pUnSubClassCombo(cbo As ComboBox) 
    Call SetWindowLong(cbo.hwnd, GWL_WNDPROC, glPrevWndProcC) 
End Sub 
 
Public Function pMyWindowProcC(ByVal hw As Long, ByVal uMsg As Long, _ 
    ByVal wParam As Long, ByVal lParam As Long) As Long 
    If uMsg = WM_PARENTNOTIFY And wParam = WM_RBUTTONDOWN Then 
'        Call frmMain.Text2_MouseUp(vbRightButton, 0, 0, 0) 
        Exit Function 
    ElseIf uMsg = WM_MOUSEWHEEL Then 
        Exit Function 
    End If 
    pMyWindowProcC = CallWindowProc(glPrevWndProcC, hw, uMsg, wParam, lParam) 
End Function 
 
Public Function fSubClassCombo(cbo As ComboBox) As Long 
    fSubClassCombo = SetWindowLong(cbo.hwnd, GWL_WNDPROC, AddressOf pMyWindowProcC) 
End Function 
 
'TextBox 
Public Function pMyWindowProc(ByVal hw As Long, ByVal uMsg As Long, _ 
    ByVal wParam As Long, ByVal lParam As Long) As Long 
    If uMsg = WM_RBUTTONUP Then 
'        Call frmMain.Text2_MouseUp(vbRightButton, 0, 0, 0) 
        Exit Function 
    End If 
    pMyWindowProc = CallWindowProc(glPrevWndProc, hw, uMsg, wParam, lParam) 
End Function 
 
Public Function fSubClass(txt As TextBox) As Long 
    fSubClass = SetWindowLong(txt.hwnd, GWL_WNDPROC, AddressOf pMyWindowProc) 
End Function 
 
Public Sub pUnSubClass(txt As TextBox) 
    Call SetWindowLong(txt.hwnd, GWL_WNDPROC, glPrevWndProc) 
End Sub 

READ MORE - ComboBox SubClassing - Private Collections