Сделал класс, с помощью которого можно модифицировать отрисовку стандартного списка (рисовать иконки, текст - все что угодно). Он имеет событие
Draw, которое вызывается когда нужно отриcовать очередной элемент списка. Для работы, нужно установить у списка стиль
Checked (флажки), и присвоить данный ListBox свойству
clsTrickListBox.ListBox. Также можно изменять высоту элементов и отменять отрисовку.
- Код: Выделить всё
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
';)
Private Function CreateAsm() As Long
Dim inIDE As Boolean
Dim AsmSize As Long
Dim ptr As Long
Dim isFirst As Boolean
If mControl Is Nothing Then Exit Function
lpPrev = GetWindowLong(mControl.hwnd, GWL_WNDPROC)
Debug.Assert MakeTrue(inIDE)
If inIDE Then AsmSize = &H3E Else AsmSize = &H1D
hHeap = GetPrevHeap()
If hHeap Then
If inIDE Then
Dim flag As Long
ptr = GetFlagPointer()
GetMem4 ByVal ptr, flag
If flag Then
FreeHeap
isFirst = True
AsmSize = AsmSize + &H4
End If
End If
Else
hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
If hHeap = 0 Then Err.Raise 7: Exit Function
If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: Err.Raise 7: Exit Function
isFirst = True
If inIDE Then AsmSize = AsmSize + &H4
End If
lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
If lpAsm = 0 Then
If isFirst Then HeapDestroy hHeap
hHeap = 0
Err.Raise 7
Exit Function
End If
Dim prv As Long
Dim i As Long
If inIDE Then
If isFirst Then
GetMem4 0&, ByVal lpAsm
lpAsm = lpAsm + 4
End If
End If
ptr = lpAsm
If inIDE Then CreateIDEStub (ptr): ptr = ptr + &H21
CreateStackConv ptr
CreateAsm = True
End Function
Private Function GetFlagPointer() As Long
Dim he As PROCESS_HEAP_ENTRY
HeapLock hHeap
Do While HeapWalk(hHeap, he)
If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then GetFlagPointer = he.lpData: Exit Function
Loop
HeapUnlock hHeap
End Function
Private Function CountTrickList() As Long
Dim he As PROCESS_HEAP_ENTRY
HeapLock hHeap
Do While HeapWalk(hHeap, he)
If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then CountTrickList = CountTrickList + 1
Loop
HeapUnlock hHeap
End Function
Private Sub FreeHeap()
Dim he As PROCESS_HEAP_ENTRY
HeapLock hHeap
Do While HeapWalk(hHeap, he)
If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then
HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal he.lpData
End If
Loop
HeapUnlock hHeap
End Sub
Private Function SaveCurHeap() As Boolean
Dim i As Long
Dim out As String
out = Hex(hHeap)
For i = Len(out) + 1 To 8: out = "0" & out: Next
SaveCurHeap = SetEnvironmentVariable(StrPtr("TrickListBox"), StrPtr(out))
End Function
Private Function GetPrevHeap() As Long
Dim out As String
out = Space(&H8)
If GetEnvironmentVariable(StrPtr("TrickListBox"), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
End Function
Private Function CreateStackConv(ByVal ptr As Long) As Boolean
Dim lpMeth As Long
Dim vTable As Long
GetMem4 ByVal ObjPtr(Me), vTable
GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
GetMem4 &H5450C031, ByVal ptr + &H0: GetMem4 &H488DE409, ByVal ptr + &H4: GetMem4 &H2474FF04, ByVal ptr + &H8
GetMem4 &H68FAE018, ByVal ptr + &HC: GetMem4 &H0, ByVal ptr + &H10: GetMem4 &HE8, ByVal ptr + &H14
GetMem4 &H10C25800, ByVal ptr + &H18: GetMem4 &H9000, ByVal ptr + &H1C
GetMem4 ObjPtr(Me), ByVal ptr + &H10 ' Push Me
GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call WndProc
End Function
Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
Dim hInstVB6 As Long
Dim lpEbMode As Long
Dim hInstUser32 As Long
Dim lpCallProc As Long
hInstVB6 = GetModuleHandle("vba6")
If hInstVB6 = 0 Then Exit Function
hInstUser32 = GetModuleHandle("user32")
If hInstUser32 = 0 Then Exit Function
lpEbMode = GetProcAddress(hInstVB6, "EbMode")
If lpEbMode = 0 Then Exit Function
lpCallProc = GetProcAddress(hInstUser32, "CallWindowProcA")
If lpCallProc = 0 Then Exit Function
GetMem4 &HE8, ByVal ptr + &H0: GetMem4 &H74C08400, ByVal ptr + &H4: GetMem4 &H74013C10, ByVal ptr + &H8
GetMem4 &H685814, ByVal ptr + &HC: GetMem4 &H50000000, ByVal ptr + &H10: GetMem4 &HE9, ByVal ptr + &H14
GetMem4 &HDFF00, ByVal ptr + &H18: GetMem4 &HEB000000, ByVal ptr + &H1C: GetMem4 &HEC, ByVal ptr + &H20
GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0 ' Call EbMode
GetMem4 lpPrev, ByVal ptr + &HF ' Push PrevProc
GetMem4 lpCallProc - (ptr + &H14) - 5, ByVal ptr + 1 + &H14 ' Jmp CallWindowProcA
GetMem4 ptr - 4, ByVal ptr + &H1B ' dec dword ptr [Flag]
CreateIDEStub = True
End Function
Private Function MakeTrue(Value As Boolean) As Boolean: Value = True: MakeTrue = True: End Function
