Использование картинки для фона Listbox

' Module.bas

Option Explicit

Public 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

Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, _
           ByVal lpRect As Long, ByVal bErase As Long) As Long

Public Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) _
           As Long

Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) _
           As Long

Private Const WM_CTLCOLORLISTBOX = &H134
Private Const WM_VSCROLL = &H115
Private Const WM_ERASEBKGND = &H14
Public Const GWL_WNDPROC = (-4)

Public Const TRANSPARENT = 1
Public Const OPAQUE = 2

Public hBrush As Long
Public prevFuncPointer As Long
Public prevListboxFuncPointer As Long

Public Function frmWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, _
            ByVal lParam As Long) As Long

    If (uMsg = WM_CTLCOLORLISTBOX) And hBrush <> 0 Then
        ' Устанавливаем прозрачный режим
        SetBkMode wParam, TRANSPARENT

        ' Разрешаем оригинальному процессу устанавливать цвета текста и т.д. из свойств списка
        CallWindowProc prevFuncPointer, hwnd, uMsg, wParam, lParam

        ' Используем нашу текущую кисть вместо кисти по умолчанию
        frmWndProc = hBrush
    Else
        frmWndProc = CallWindowProc(prevFuncPointer, hwnd, uMsg, wParam, lParam)
    End If
End Function

Public Function lbWndProc(ByVal hwnd As Long, ByVal uMsg As Long, _
           ByVal wParam As Long, ByVal lParam As Long) As Long

    ' Заставляем список обновляться при каждом скроллинге

    If uMsg = WM_VSCROLL Then
        ' Перерисовываем список
        InvalidateRect hwnd, 0, 0

        ' Вызываем процесс по умолчанию
        lbWndProc = CallWindowProc(prevListboxFuncPointer, hwnd, uMsg, wParam, lParam)

    ElseIf uMsg = WM_ERASEBKGND Then
        ' Ничего не возвращаем
        lbWndProc = 1
    Else
        ' Вызываем процесс по умолчанию
        lbWndProc = CallWindowProc(prevListboxFuncPointer, hwnd,  uMsg, wParam, lParam)
    End If

End Function


'Form1.frm

Private Sub Form_Load()
    ' Добавляйте новые пункты в Listbox в рантайм!
    Dim i as integer
    For i=0 to 100
        list1.AddItem "Item# " & i
    Next
    ' Создаем кисть на основе картинки
    ' используйте картинку из Image1
    hBrush = CreatePatternBrush(Image1.Picture.Handle)
    
    ' Сабклассинг окна
    prevFuncPointer = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf frmWndProc)
    
    prevListBoxFuncPointer = SetWindowLong(List1.hwnd, GWL_WNDPROC, AddressOf lbWndProc)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' Unsubclass (return the original processes)
    SetWindowLong Me.hwnd, GWL_WNDPROC, prevFuncPointer
    SetWindowLong List1.hwnd, GWL_WNDPROC, prevListBoxFuncPointer
End Sub

Реклама