Make a class with which you can modify the drawing standard list. He has event Draw, which is caused when the need render the next element of the list. To work, you need to install in the list of style Checked (flags), and assign this property ListBox clsTrickListBox.ListBox. You can also change the height of the elements and to cancel drawing.
Code:
Option Explicit
' Класс clsTrickListBox.cls - для ручной отрисовки стандартного ListBox'а
' © Кривоус Анатолий Анатольевич (The trick), 2014
Public Enum StateEnum
ES_NORMAL
ES_FOCUSED
ES_SELECTED
End Enum
Private Type PROCESS_HEAP_ENTRY
lpData As Long
cbData As Long
cbOverhead As Byte
iRegionIndex As Byte
wFlags As Integer
dwCommittedSize As Long
dwUnCommittedSize As Long
lpFirstBlock As Long
lpLastBlock As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type DRAWITEMSTRUCT
CtlType As Long
ctlId As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 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 DrawText Lib "user32" Alias "DrawTextW" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetDlgCtrlID Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetDCBrushColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function SetDCPenColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const WM_GETFONT As Long = &H31
Private Const WM_DRAWITEM As Long = &H2B
Private Const LB_GETITEMHEIGHT As Long = &H1A1
Private Const LB_SETITEMHEIGHT As Long = &H1A0
Private Const LB_GETCARETINDEX As Long = &H19F
Private Const TRANSPARENT As Long = 1
Private Const ODS_SELECTED As Long = &H1
Private Const ODS_FOCUS As Long = &H10
Private Const ODA_DRAWENTIRE As Long = &H1
Private Const ODA_FOCUS As Long = &H4
Private Const ODA_SELECT As Long = &H2
Private Const HEAP_CREATE_ENABLE_EXECUTE As Long = &H40000
Private Const HEAP_NO_SERIALIZE As Long = &H1
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Const PROCESS_HEAP_ENTRY_BUSY As Long = &H4
Private Const GWL_WNDPROC As Long = &HFFFFFFFC
Private Const DC_BRUSH As Long = 18
Private Const WNDPROCINDEX As Long = 6
Private mControl As ListBox
Private mDefDraw As Boolean
Dim hHeap As Long
Dim lpAsm As Long
Dim lpPrev As Long
Dim pHwnd As Long
Dim mHwnd As Long
Dim ctlId As Long
Public Event Draw(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal width As Long, ByVal height As Long, _
ByVal index As Long, ByVal State As StateEnum)
' Задает список, который нужно отрисовывать
Public Property Get ListBox() As ListBox
Set ListBox = mControl
End Property
Public Property Set ListBox(Value As ListBox)
If Not mControl Is Nothing Then Err.Raise 5: Exit Property
Set mControl = Value
If CreateAsm() = 0 Then
Set mControl = Nothing
Else
pHwnd = mControl.Container.hwnd
mHwnd = mControl.hwnd
ctlId = GetDlgCtrlID(mHwnd)
Subclass
End If
End Property
' Использовать отрисовку по умолчанию
Public Property Get DefaultDraw() As Boolean
DefaultDraw = mDefDraw
End Property
Public Property Let DefaultDraw(ByVal Value As Boolean)
mDefDraw = Value
If Not mControl Is Nothing Then mControl.Refresh
End Property
' Задает высоту элемента списка
Public Property Get ItemHeight() As Byte
If mControl Is Nothing Then Err.Raise 5: Exit Property
ItemHeight = SendMessage(mHwnd, LB_GETITEMHEIGHT, 0, ByVal 0&)
End Property
Public Property Let ItemHeight(ByVal Value As Byte)
If mControl Is Nothing Then Err.Raise 5: Exit Property
SendMessage mHwnd, LB_SETITEMHEIGHT, 0, ByVal CLng(Value)
End Property
' Оконная процедура
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case WM_DRAWITEM
WndProc = OnDrawItem(wParam, lParam)
Case Else
WndProc = DefCall(Msg, wParam, lParam)
End Select
End Function
' Вызов процедур по умолчанию
Private Function DefCall(ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
DefCall = CallWindowProc(lpPrev, pHwnd, Msg, wParam, lParam)
End Function
' Процедура отрисовки
Private Function OnDrawItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim ds As DRAWITEMSTRUCT
Dim oft As Long
If wParam <> ctlId Then
OnDrawItem = DefCall(WM_DRAWITEM, wParam, lParam)
Exit Function
End If
CopyMemory ds, ByVal lParam, Len(ds)
oft = SelectObject(ds.hdc, SendMessage(mHwnd, WM_GETFONT, 0, ByVal 0&))
SetBkMode ds.hdc, TRANSPARENT
SetTextColor ds.hdc, ToRGB(mControl.ForeColor)
Select Case ds.itemAction
Case ODA_SELECT
Case Else
If ds.itemState And ODS_FOCUS Then
If mDefDraw Then
DrawSelected ds
DrawFocusRect ds.hdc, ds.rcItem
Else
RaiseEvent Draw(ds.hdc, ds.rcItem.Left, ds.rcItem.Top, ds.rcItem.Right - ds.rcItem.Left, _
ds.rcItem.Bottom - ds.rcItem.Top, ds.itemID, ES_FOCUSED)
End If
ElseIf mHwnd = GetFocus Then
If mDefDraw Then
DrawEntire ds
Else
RaiseEvent Draw(ds.hdc, ds.rcItem.Left, ds.rcItem.Top, ds.rcItem.Right - ds.rcItem.Left, _
ds.rcItem.Bottom - ds.rcItem.Top, ds.itemID, ES_NORMAL)
End If
Else
If ds.itemID = SendMessage(mHwnd, LB_GETCARETINDEX, 0, ByVal 0&) Then
SetTextColor ds.hdc, ToRGB(vbHighlightText)
If mDefDraw Then
DrawSelected ds
Else
RaiseEvent Draw(ds.hdc, ds.rcItem.Left, ds.rcItem.Top, ds.rcItem.Right - ds.rcItem.Left, _
ds.rcItem.Bottom - ds.rcItem.Top, ds.itemID, ES_SELECTED)
End If
Else
If mDefDraw Then
DrawEntire ds
Else
RaiseEvent Draw(ds.hdc, ds.rcItem.Left, ds.rcItem.Top, ds.rcItem.Right - ds.rcItem.Left, _
ds.rcItem.Bottom - ds.rcItem.Top, ds.itemID, ES_NORMAL)
End If
End If
End If
End Select
SelectObject ds.hdc, oft
OnDrawItem = 1
End Function
' Получить цвет RGB из OLE_COLOR
Private Function ToRGB(ByVal Color As OLE_COLOR) As Long
If Color < 0 Then
ToRGB = GetSysColor(Color And &HFFFFFF)
Else: ToRGB = Color
End If
End Function
' Отрисовка выделенного пункта
Private Sub DrawSelected(ds As DRAWITEMSTRUCT)
Dim txt As String, oBr As Long
oBr = SelectObject(ds.hdc, GetStockObject(DC_BRUSH))
SetDCBrushColor ds.hdc, ToRGB(vbHighlight)
SetTextColor ds.hdc, ToRGB(vbHighlightText)
SetBkColor ds.hdc, ToRGB(vbHighlight)
PatBlt ds.hdc, ds.rcItem.Left, ds.rcItem.Top, ds.rcItem.Right - ds.rcItem.Left, ds.rcItem.Bottom - ds.rcItem.Top, vbPatCopy
If ds.itemID >= 0 Then
txt = mControl.List(ds.itemID)
DrawText ds.hdc, StrPtr(txt), Len(txt), ds.rcItem, 0
End If
SelectObject ds.hdc, oBr
End Sub
' Отрисовка невыделенного пункта
Private Sub DrawEntire(ds As DRAWITEMSTRUCT)
Dim txt As String, oBr As Long
oBr = SelectObject(ds.hdc, GetStockObject(DC_BRUSH))
SetDCBrushColor ds.hdc, ToRGB(mControl.BackColor)
SetTextColor ds.hdc, ToRGB(mControl.ForeColor)
PatBlt ds.hdc, ds.rcItem.Left, ds.rcItem.Top, ds.rcItem.Right - ds.rcItem.Left, ds.rcItem.Bottom - ds.rcItem.Top, vbPatCopy
If ds.itemID >= 0 Then
txt = mControl.List(ds.itemID)
DrawText ds.hdc, StrPtr(txt), Len(txt), ds.rcItem, 0
End If
SelectObject ds.hdc, oBr
End Sub
' Сабклассинг
Private Function Subclass() As Boolean
Subclass = SetWindowLong(pHwnd, GWL_WNDPROC, lpAsm)
End Function
' Снять сабклассинг
Private Function Unsubclass() As Boolean
Unsubclass = SetWindowLong(pHwnd, GWL_WNDPROC, lpPrev)
End Function
' Конструктор класса
Private Sub Class_Initialize()
mDefDraw = True
End Sub
' Деструктор класса
Private Sub Class_Terminate()
If hHeap = 0 Then Exit Sub
Unsubclass
If CountTrickList() = 1 Then
HeapDestroy hHeap
hHeap = 0
SaveCurHeap
Else
HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
End If
End Sub