Фоновое изображение на ListBox и Slider - VB
Формулировка задачи:
Хотелось бы узнать, можно установить изображение как фон в ListBox?
Решение задачи: «Фоновое изображение на ListBox и Slider»
textual
Листинг программы
Option Explicit 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 Form_Load() ' Создаем кисть для отрисовки фона на основе фонового изображения формы hBackBrush = CreatePatternBrush(Me.Picture.Handle) ' Сабклассинг формы Set wndProc = New clsTrickSubclass Set lstProc = New clsTrickSubclass wndProc.Hook Me.hwnd lstProc.Hook lstTestList.hwnd ' Добавляем в список тестовые значения Do While lstTestList.ListCount < 100 lstTestList.AddItem Format(lstTestList.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 = lstTestList.hwnd Then ' Устанавливаем прозрачный фон для текста SetBkMode wParam, TRANSPARENT ' Устанавливаем цвет текста SetTextColor wParam, vbWhite End If ' Возвращаем кисть Ret = hBackBrush Case Else: DefCall = True ' Остальное оставляем без изменений End Select End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д