ComboBox для выбора цветов

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

Option Explicit
 
Dim WithEvents cboTest As ComboBox
Dim WithEvents cboHex As ComboBox
 
Private Sub cboTest_Click()
    MsgBox cboTest.List(cboTest.ListIndex)
End Sub
 
Private Sub Form_Load()
    Dim i As Long, r As Long, g As Long, b As Long, c As Long, s As String
    
    Set cboTest = modSubclass.CreateOwnerdrawCombo(Me, "cboTest")
    cboTest.AddItem "Red"
    cboTest.itemData(cboTest.NewIndex) = vbRed
    cboTest.AddItem "Blue"
    cboTest.itemData(cboTest.NewIndex) = vbBlue
    cboTest.AddItem "Green"
    cboTest.itemData(cboTest.NewIndex) = vbGreen
    cboTest.AddItem "Yellow"
    cboTest.itemData(cboTest.NewIndex) = vbYellow
    cboTest.AddItem "Cyan"
    cboTest.itemData(cboTest.NewIndex) = vbCyan
    cboTest.AddItem "Magenta"
    cboTest.itemData(cboTest.NewIndex) = vbMagenta
    cboTest.AddItem "Black"
    cboTest.itemData(cboTest.NewIndex) = vbBlack
    cboTest.AddItem "White"
    cboTest.itemData(cboTest.NewIndex) = vbWhite
    cboTest.Move 10, 10, 200
    cboTest.Visible = True
    Set cboHex = modSubclass.CreateOwnerdrawCombo(Me, "cboHex")
    
    Do
        c = RGB(r, g, b)
        s = "0x000000"
        Mid$(s, 9 - Len(Hex(c))) = Hex(c)
        cboHex.AddItem s
        cboHex.itemData(cboHex.NewIndex) = c
        r = r + &H20
        If r > 255 Then r = 0: g = g + &H20
        If g > 255 Then g = 0: b = b + &H20
        If b > 255 Then Exit Do
    Loop
    cboHex.Move 10, 40, 200
    cboHex.Visible = True
End Sub