Code:
Option Explicit
Private Declare Function ReleaseCapture Lib "user32" () 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 WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Const TRANSPARENT As Long = 1
Private Const WM_CTLCOLORLISTBOX As Long = &H134
Private Const WM_CTLCOLORSTATIC As Long = &H138
Private Const WM_VSCROLL As Long = &H115
Dim WithEvents WndProc As clsTrickSubclass ' Объект для сабклассинга формы
Dim WithEvents lstProc As clsTrickSubclass ' Объект для сабклассинга списка
Dim hBackBrush As Long ' Фоновая кисть
Private Sub list1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Call ReleaseCapture
SendMessage List1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
List1.Refresh
End If
End Sub
Private Sub Form_Load()
'Set a larger background image test.jpg for the form, and move the text box to see the transparency effect
Me.Picture = LoadPicture(App.Path & "\test.jpg")
' Создаем кисть для отрисовки фона на основе фонового изображения формы
hBackBrush = CreatePatternBrush(Me.Picture.Handle)
' Сабклассинг формы
Set WndProc = New clsTrickSubclass
Set lstProc = New clsTrickSubclass
WndProc.Hook Me.hwnd
lstProc.Hook List1.hwnd
' Добавляем в список тестовые значения
Do While List1.ListCount < 100
List1.AddItem Format(List1.ListCount, "ITE\M 00")
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Удаляем кисть
DeleteObject hBackBrush
End Sub
' Оконная процедура списка
Private Sub lstProc_wndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
Select Case Msg
' При прокрутке списка
Case WM_VSCROLL
' Объявляем всю область списка недействительной и требующей перерисовки
InvalidateRect hwnd, ByVal 0&, 0
End Select
' Вызов по умолчанию
DefCall = True
End Sub
' Оконная процедура формы
Private Sub wndProc_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
Select Case Msg
' При запросе кисти фона списка или слайдера
Case WM_CTLCOLORSTATIC, WM_CTLCOLORLISTBOX
Dim pts(1) As Long
' Получаем координаты элемента
MapWindowPoints lParam, Me.hwnd, pts(0), 1
' Сдвигаем точку отсчета координат кисти, чтобы она совпадала с фоновом изображением под контролом
SetBrushOrgEx wParam, -pts(0), -pts(1), ByVal 0&
' Если это список
If lParam = List1.hwnd Then
' Устанавливаем прозрачный фон для текста
SetBkMode wParam, TRANSPARENT
' Устанавливаем цвет текста
SetTextColor wParam, vbWhite
End If
' Возвращаем кисть
Ret = hBackBrush
Case Else: DefCall = True ' Остальное оставляем без изменений
End Select
End Sub