Api To Make Double Columns

[Luis Moises Rojas]

I heard there is an API that u could call to make double columns in a combobox. Can anyone tell where is that API?

[Edneeis]

You can on a listbox, I'm not sure about a combo. You can use SendMessage and set a tab length which makes it appear to have columns. Then when you add something that you want to go to the next column just use tab where the column should be.

Here is a sampel project.

[Microbasic]

I agree with Edneeis and Stanich. You can't do it even with the most complex of APIs. I spend about three hours ownerdrawing and subclassing comboboxes and the farthest i've gotten is something that LOOKS like it has 2 cols but really behaves like half of one row is for the Col1 item and half of Row2 is for the 2nd ite, (at this point, James Stanich probably already figured what I am trying to do ).

You could add a listbox below the combobox and hide it and use IT as the selection structure.

[Microbasic]

BTW, just in case if you're wondering, here's my currently unfinished code. Maybe someone else could use this to finish what I failed to do?

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public 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
Public Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type
Public Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To 32) As Byte
End Type
Public Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type
 
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public 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
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Declare Function SendMessageLng Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Public Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
 
'-----------------------------------------------
'TextParam
Public Const DT_SINGLELINE = &H20
 
'-----------------------------------------------
'Combobox Styles
Public Const CBS_OWNERDRAWVARIABLE = &H20&
Public Const CBS_HASSTRINGS = &H200&
Public Const CBS_AUTOHSCROLL = &H40&
Public Const CBS_DROPDOWNLIST = &H3&
 
'------------------------------------------
'Window Styles
Public Const WS_CHILD = &H40000000
Public Const WS_CLIPCHILDREN = &H2000000
Public Const WS_CLIPSIBLINGS = &H4000000
Public Const WS_OVERLAPPED = &H0&
Public Const WS_VISIBLE = &H10000000
Public Const WS_VSCROLL = &H200000
 
'--------------------------------------------
'MISC.
Public Const GCL_HBRBACKGROUND = (-10)
 
Public Const WM_CTLCOLORLISTBOX = &H134
Public Const WM_DESTROY = &H2
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
Public Const WM_PAINT = &HF
 
Public Const GWL_STYLE = (-16)
 
Public Const ODS_FOCUS = &H10
Public Const ODT_COMBOBOX = 3
Public Const OBJ_FONT = 6
 
Public Const CB_ADDSTRING = &H143
Public Const CB_GETITEMDATA = &H150
Public Const CB_GETITEMHEIGHT = &H154
Public Const CB_GETLBTEXT = &H148
Public Const CB_GETLBTEXTLEN = &H149
Public Const CB_SETITEMDATA = &H151
 
Public hwndList As Long
Public hdcList As Long
Public wtbrush As Long
Public procOld As Long
 
Public ListHeight As Long
Public ListWidth As Long
Dim hfont As Long
Public bolPlace As Boolean
 
Public Function WndProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim tItem As DRAWITEMSTRUCT
    Dim mItem As MEASUREITEMSTRUCT
    Dim tmetric As TEXTMETRIC
    Dim sBuff As String * 255
    Dim sItem As String
    Dim lBack As Long
    Dim icback As Long
    Dim rsct As RECT
    Dim temp As Long, pictop As Long
    
    Select Case iMsg
    Case WM_MEASUREITEM
        Call CopyMemory(mItem, ByVal lParam, Len(mItem))
        'If mItem.CtlType = ODT_COMBOBOX Then
            Call SendMessage(hwndList, CB_GETLBTEXT, mItem.itemID, ByVal sBuff)
            sItem = Left(sBuff, InStr(sBuff, Chr(0)) - 1)
            'mItem.itemHeight = 56
            mItem.itemWidth = mItem.itemWidth
            
            GetTextMetrics GetDC(hwndList), tmetric
            temp = tmetric.tmHeight
            If mItem.itemID = -1 Then mItem.itemHeight = temp Else mItem.itemHeight = temp / 2
            
            Call CopyMemory(ByVal lParam, mItem, Len(mItem))
            
            WndProc = True
            Exit Function
        'End If
    Case WM_DRAWITEM
        Call CopyMemory(tItem, ByVal lParam, Len(tItem))
        'If tItem.CtlType = ODT_COMBOBOX Then
            Call SendMessage(tItem.hwndItem, CB_GETLBTEXT, tItem.itemID, ByVal sBuff)
            sItem = Left(sBuff, InStr(sBuff, Chr(0)) - 1)
            
            GetTextMetrics GetDC(hwndList), tmetric
            temp = tmetric.tmHeight
            
            'If tItem.itemID = -1 Then
            If tItem.itemState = 4096 Or tItem.itemState = 4113 Then
            ElseIf tItem.itemData = 1 Then
                tItem.rcItem.Left = (tItem.rcItem.Left + tItem.rcItem.Right) / 2
                tItem.rcItem.Top = tItem.rcItem.Top * 2 - tItem.rcItem.Bottom
                tItem.rcItem.Bottom = tItem.rcItem.Top + temp
                'tItem.rcItem.Top = 0
            Else
                tItem.rcItem.Right = (tItem.rcItem.Left + tItem.rcItem.Right) / 2
                tItem.rcItem.Bottom = tItem.rcItem.Bottom * 2 - tItem.rcItem.Top
            End If
            If (tItem.itemState And ODS_FOCUS) Then
                icback = GetSysColor(&HD)
                lBack = CreateSolidBrush(icback)
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                Call SetBkColor(tItem.hdc, icback)
                icback = GetSysColor(&HE)
                Call SetTextColor(tItem.hdc, icback)
                DrawText tItem.hdc, ByVal sItem, Len(sItem), tItem.rcItem, &H20
                DrawFocusRect tItem.hdc, tItem.rcItem
            Else
                icback = GetSysColor(&H5)
                lBack = CreateSolidBrush(icback)
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                Call SetBkColor(tItem.hdc, icback)
                icback = GetSysColor(8)
                Call SetTextColor(tItem.hdc, icback)
                DrawText tItem.hdc, ByVal sItem, Len(sItem), tItem.rcItem, &H20
            End If
            Call DeleteObject(lBack)
            
            WndProc = True
            Exit Function
        'End If
    End Select
    WndProc = CallWindowProc(procOld, hwnd, iMsg, wParam, lParam)
End Function
 
Public Sub StrCpy(ByteArr() As Byte, ByVal Text As String)
    Dim i As Long
    For i = 1 To Len(Text)
        If (i + LBound(ByteArr) - 1) < UBound(ByteArr) Then ByteArr(i + LBound(ByteArr) - 1) = Asc(Mid$(Text, i, 1))
    Next
End Sub
 
Public Function StrToByte(ByVal Text As String) As Variant
    Dim ByteArr() As Byte
    ReDim ByteArr(Len(Text))
    Dim i As Long
    For i = 1 To Len(Text)
        If (i + LBound(ByteArr) - 1) < UBound(ByteArr) Then ByteArr(i + LBound(ByteArr) - 1) = Asc(Mid$(Text, i, 1))
    Next
    StrToByte = ByteArr
End Function
 
Public Function Syscolor(Color As OLE_COLOR) As Long
    Dim icback As Long
    If (Color And &HFF000000) = &H80000000 Then icback = GetSysColor(Color - &H80000000) Else icback = BGColor
    Syscolor = icback
End Function

[Microbasic]

That was the module code. here's the form code:

Private Sub Form_Load()
    Dim Lgfnt As LOGFONT
    Dim tmetric As TEXTMETRIC
    
    procOld = SetWindowLong(Me.hwnd, -4, AddressOf WndProc)
    
    GetTextMetrics Me.hdc, tmetric
    temp = tmetric.tmHeight
    hwndList = CreateWindowEx(&H0, "combobox", "", WS_VISIBLE Or WS_CHILD Or CBS_AUTOHSCROLL Or CBS_HASSTRINGS Or CBS_OWNERDRAWVARIABLE Or CBS_DROPDOWNLIST, 2, 2, 250, 250, Me.hwnd, 1, App.hInstance, &H0)
    Lgfnt.lfHeight = temp '-1 * m_ListItems.Item(mItem.itemData).Font.Size Or WS_MAXIMIZEBOX Or WS_OVERLAPPED Or WS_CLIPSIBLINGS Or WS_CLIPCHILDREN
    Lgfnt.lfWidth = 0
    Lgfnt.lfEscapement = 0
    Lgfnt.lfOrientation = 0
    Lgfnt.lfWeight = IIf(Me.FontBold, 700, 0)
    Lgfnt.lfItalic = Abs(Me.FontItalic)
    Lgfnt.lfUnderline = Abs(Me.FontUnderline)
    Lgfnt.lfStrikeOut = Abs(Me.FontStrikethru)
    Lgfnt.lfCharSet = Me.Font.Charset
    Lgfnt.lfOutPrecision = 0
    Lgfnt.lfClipPrecision = 0
    Lgfnt.lfQuality = 0
    Lgfnt.lfPitchAndFamily = 0
    StrCpy Lgfnt.lfFaceName(), Me.FontName
    hfont = CreateFontIndirect(Lgfnt)
    hfont = SelectObject(GetDC(hwndList), hfont)
    
    AddItem "Hello"
    AddItem "BYBY"
    AddItem "CRASH?"
    AddItem "CRASH?2"
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Call SetWindowLong(Me.hwnd, -4, procOld)
End Sub
 
Public Function AddItem(Text As String)
    Dim place As Long
    
    place = SendMessageStr(hwndList, CB_ADDSTRING, 0, Text)
    Call SendMessageLng(hwndList, CB_SETITEMDATA, place, Abs(bolPlace))
    bolPlace = Not bolPlace
End Function

[James Stanich]

Micro : I too screwed around with tring to make a control behave in the same manner. But, after days of screwing around with it, I eventually abandoned (besides how may times do you see a combobox with multiple columns anyway?)

[Edneeis]

This is the best thing I've found for making a multicolumn combo, and it's kind of cheating.

http://www.mvps.org/vbnet/index.html...bolistview.htm

[James Stanich]

This is what I meant about using the flexgrid (no subclassing required)

[Luis Moises Rojas]

Originally posted by James Stanich
Micro : I too screwed around with tring to make a control behave in the same manner. But, after days of screwing around with it, I eventually abandoned (besides how may times do you see a combobox with multiple columns anyway?)

Morning everyone!

Well, first i will try to check the code, second: Here, in the best place of the third rock from the sun (Dominican Republic) u have to use a combobox almost everyday, the problem is that you cannot do it, but people always ask for it.

Third: How can i use a MsFlexGrid like a combobox to have 2 columns?

[Wokawidget]

Couldn't you just write your own in a usercontrol?
Subclass the combo box, when the drop down is called, cancel it and display a listview or something instead?
To make the combo look like the selected item has columns use:

strEntry = Left("London" & Space(15),15)
strEntry = strEntry & Left("England" & Space(15),15)
'Etc
Combo1.AddItem strEntry

Then just add the same into the listview, which has columns...???

Understand what I'm getting at???

Woka

[Luis Moises Rojas]

Thanks wokawidget!
I will do it. It is a great idea.

[Wokawidget]

Originally posted by Edneeis
This is the best thing I've found for making a multicolumn combo, and it's kind of cheating.

http://www.mvps.org/vbnet/index.html...bolistview.htm

Errr...just realised that Edneeis posted the same thing a suggested, apart from the example it the link above doesn't use the Left comamnd to make the combo appear to have columns...

Sorry Ed, wasn't stealing your idea, just didn't read it properly...

Woka

[Edneeis]

Well technically its the VB.Net guy's idea so steal away. :>