[VB6] - Combobox for color selection.-VBForums
Results 1 to 2 of 2

Thread: [VB6] - Combobox for color selection.

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Feb 2015
    Posts
    855

    [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
    Attached Files Attached Files

  2. #2
    Member
    Join Date
    Mar 2015
    Posts
    58

    Re: [VB6] - Combobox for color selection.

    Hi there,

    Thanks for "Combobox for color selection". Looks nice. I would like to try it out on a few drawing programs that I have been playing around with.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.