[VB6] - Combobox for color selection.

Standard VB combo box does not allow standard means to draw on the list. To work around this limitation, in its module I use OWNERDRAW style combo box. After small completion, you can do anything with the list.

Code:

Option Explicit ' Модуль для создания комбинированного списка с выбором цветов ' © Кривоус Анатолий Анатольевич (The trick), 2014 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 Type MEASUREITEMSTRUCT CtlType As Long CtlID As Long itemID As Long itemWidth As Long itemHeight As Long itemData As Long End Type Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) 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 GetStockObject Lib "gdi32" (ByVal nIndex 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, lpStr As Any, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 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 COLOR_WINDOW As Long = 5 Private Const COLOR_WINDOWTEXT As Long = 8 Private Const COLOR_HIGHLIGHT As Long = 13 Private Const COLOR_HIGHLIGHTTEXT As Long = 14 Private Const ODS_SELECTED As Long = &H1 Private Const DC_PEN As Long = 19 Private Const DC_BRUSH As Long = 18 Private Const WH_CBT As Long = 5 Private Const HCBT_CREATEWND As Long = 3 Private Const GWL_WNDPROC = &HFFFFFFFC Private Const ODT_COMBOBOX As Long = 3 Private Const CBS_OWNERDRAWFIXED As Long = &H10& Private Const CBS_DROPDOWNLIST As Long = &H3& Private Const CBS_HASSTRINGS As Long = &H200& Private Const WM_MEASUREITEM As Long = &H2C Private Const WM_DRAWITEM = &H2B Private Const GWL_STYLE As Long = &HFFFFFFF0 Private Const WM_DESTROY As Long = &H2 Private Const DT_SINGLELINE As Long = &H20, DT_VCENTER As Long = &H4 Private Const CB_GETLBTEXT As Long = &H148 Private Const CB_GETLBTEXTLEN As Long = &H149 Dim hHook As Long Public Function CreateOwnerdrawCombo(Form As Form, Name As String, Optional Container As Control) As ComboBox Dim Prev As Long hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, 0, App.ThreadID) If Container Is Nothing Then Set CreateOwnerdrawCombo = Form.Controls.Add("VB.ComboBox", Name) Else: Set CreateOwnerdrawCombo = Form.Controls.Add("VB.ComboBox", Name, Container) End If UnhookWindowsHookEx hHook If Not CreateOwnerdrawCombo Is Nothing Then Prev = GetProp(CreateOwnerdrawCombo.Container.hwnd, "prev") If Prev = 0 Then Prev = SetWindowLong(CreateOwnerdrawCombo.Container.hwnd, GWL_WNDPROC, AddressOf WndProc) SetProp CreateOwnerdrawCombo.Container.hwnd, "prev", Prev End If End If End Function Private Function CBTProc(ByVal uCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If uCode = HCBT_CREATEWND Then Dim Class As String, l As Long, Style As Long Class = Space(256) l = GetClassName(wParam, Class, 255) If l Then Class = Left(Class, l) If StrComp(Class, "ThunderComboBox", vbTextCompare) = 0 Or _ StrComp(Class, "ThunderRT6ComboBox", vbTextCompare) = 0 Then Style = GetWindowLong(wParam, GWL_STYLE) SetWindowLong wParam, GWL_STYLE, Style Or CBS_OWNERDRAWFIXED Or CBS_DROPDOWNLIST Or CBS_HASSTRINGS End If End If End If CBTProc = CallNextHookEx(hHook, uCode, wParam, ByVal lParam) End Function Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim Prev As Long Select Case uMsg Case WM_DESTROY Prev = GetProp(hwnd, "prev") SetWindowLong hwnd, GWL_WNDPROC, Prev RemoveProp hwnd, "prev" WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam) Case WM_DRAWITEM Dim drw As DRAWITEMSTRUCT CopyMemory drw, ByVal lParam, Len(drw) If drw.CtlType = ODT_COMBOBOX Then DrawItem drw WndProc = True Else Prev = GetProp(hwnd, "prev") WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam) End If Case WM_MEASUREITEM Dim meas As MEASUREITEMSTRUCT, RC As RECT CopyMemory meas, ByVal lParam, Len(meas) If meas.CtlType = ODT_COMBOBOX Then GetClientRect hwnd, RC meas.itemWidth = RC.Right - RC.Left CopyMemory ByVal lParam, meas, Len(meas) WndProc = True Else Prev = GetProp(hwnd, "prev") WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam) End If Case Else Prev = GetProp(hwnd, "prev") WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam) End Select End Function Private Function DrawItem(drw As DRAWITEMSTRUCT) As Boolean Dim obr As Long, opn As Long, l As Long, s As String obr = SelectObject(drw.hdc, GetStockObject(DC_BRUSH)) opn = SelectObject(drw.hdc, GetStockObject(DC_PEN)) If (drw.itemState And ODS_SELECTED) Then SetDCBrushColor drw.hdc, GetSysColor(COLOR_HIGHLIGHT) SetDCPenColor drw.hdc, GetSysColor(COLOR_HIGHLIGHT) Rectangle drw.hdc, drw.rcItem.Left, drw.rcItem.Top, drw.rcItem.Right, drw.rcItem.Bottom SetDCPenColor drw.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT) SetTextColor drw.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT) Else SetDCBrushColor drw.hdc, GetSysColor(COLOR_WINDOW) SetDCPenColor drw.hdc, GetSysColor(COLOR_WINDOW) Rectangle drw.hdc, drw.rcItem.Left, drw.rcItem.Top, drw.rcItem.Right, drw.rcItem.Bottom SetDCPenColor drw.hdc, GetSysColor(COLOR_WINDOWTEXT) SetTextColor drw.hdc, GetSysColor(COLOR_WINDOWTEXT) End If SetBkMode drw.hdc, TRANSPARENT If drw.itemID >= 0 Then SetDCBrushColor drw.hdc, drw.itemData Rectangle drw.hdc, drw.rcItem.Left + 3, drw.rcItem.Top + 3, drw.rcItem.Left + 70, drw.rcItem.Bottom - 3 l = SendMessage(drw.hwndItem, CB_GETLBTEXTLEN, drw.itemID, ByVal 0) If l Then s = Space(l + 1) l = SendMessage(drw.hwndItem, CB_GETLBTEXT, drw.itemID, ByVal s) s = Left(s, l) drw.rcItem.Left = drw.rcItem.Left + 78 End If Else drw.rcItem.Left = drw.rcItem.Left + 2 s = "None" End If DrawText drw.hdc, ByVal s, Len(s), drw.rcItem, DT_VCENTER Or DT_SINGLELINE SelectObject drw.hdc, obr SelectObject drw.hdc, opn End Function

http://s1.hostingkartinok.com/upload...718c0870b7.png