[SRC] cListBoxMultiAlign [by Mr. Frog ©]

[*PsyKE1*]

I leave my last class used to justify text in a ListBox, the novelty is that you can specifically act on each Item, I leave the code:

Option Explicit
'==================================================================================================
' º Class     : MultiAlignListBox.cls
' º Version   : 1.1
' º Author    : Mr.Frog ©
' º Country   : Spain
' º Mail      : [email protected]
' º Date      : 14/12/2010
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Tested on : WinXp & Win7
' º Greets    : LaVolpe & Raul338 & BlackZer0x
' º Reference : http://www.elguille.info/colabora/vb2006/karmany_centrartextolistbox.htm
' º Recommended Websites :
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'==================================================================================================
 
Private Declare Function GetDialogBaseUnits Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) 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 GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpString As String, ByVal cbString As Long, lpSize As SIZE) As Long
 
Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type
 
Private Type SIZE
    cX      As Long
    cY      As Long
End Type
 
Private Const LB_SETTABSTOPS                        As Long = &H192&
Private Const WM_GETFONT                            As Long = &H31&
 
Private Const CHARS_LIST                            As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
Private Const CHARS_LEN                             As Long = &H3E&
 
Private myListBox                                   As ListBox
Private lListhWnd                                   As Long
Private lWidth                                      As Long
 
Public Sub SetListBox(myList As ListBox)
    If Not (myList Is Nothing) Then
        Set myListBox = myList
        lListhWnd = myListBox.hwnd
        SetRightTab
    End If
End Sub
 
Public Sub AddAlignItem(ByVal Item As String, ByVal Align As AlignmentConstants, Optional ByVal Index As Long = (-1))
Dim lCenterAlign                                    As Long
 
    With myListBox
        lCenterAlign = Int(.Width - PixelsPerUnit(Item))
        If lCenterAlign < 0 Then Align = vbLeftJustify
        
        If Index = (-1) Then Index = .ListCount
        
        Select Case Align
            Case vbRightJustify
                .AddItem vbTab & Item, Index
                If Not (lWidth = GetListSize) Then SetRightTab
            Case vbCenter
                .AddItem Space$(Abs(Int(lCenterAlign / PixelsPerUnit(Space$(1)) / 2) - 1.5)) & Item, Index
            Case Else
                .AddItem Item, Index
        End Select
    End With
End Sub
 
Public Sub ChangeListBoxAlign(Optional ByVal Index As Long = (-1), Optional ByVal Align As AlignmentConstants = vbAlignLeft)
Dim Q                                               As Long
 
    If Index > -1 Then
        SetAlign Index, Align
    Else
        For Q = 0 To (myListBox.ListCount - 1)
            SetAlign Q, Align
        Next Q
    End If
End Sub
 
Public Function GetItem(ByVal Index As Long) As String
    GetItem = LTrim$(myListBox.List(Index))
    
    If (GetItem Like (vbTab & "*")) Then
        GetItem = Right$(GetItem, (Len(GetItem) - 1))
    End If
End Function
 
Private Sub SetAlign(ByVal Index As Long, ByVal Align As AlignmentConstants)
Dim sItem                                           As String
 
    With myListBox
        sItem = GetRealItem(Index)
        If Not (.List(Index) = sItem) Then
            .RemoveItem (Index)
            AddAlignItem sItem, Align, Index
        End If
    End With
End Sub
 
Private Sub SetRightTab()
Dim lRightAlignTab                                  As Long
 
    lWidth = GetListSize
    lRightAlignTab = -(lWidth / PixelsPerUnit)
    
    SendMessage lListhWnd, LB_SETTABSTOPS, &H0&, ByVal &H0&
    SendMessage lListhWnd, LB_SETTABSTOPS, &H1&, lRightAlignTab
    
    myListBox.Refresh
End Sub
 
Private Function GetListSize() As Long
Dim RCT                                             As RECT
 
    GetClientRect lListhWnd, RCT
    With RCT
        GetListSize = (.Right - .Left)
    End With
End Function
 
 
Private Function PixelsPerUnit(Optional ByVal sText As String) As Single
Dim hDC                                             As Long
Dim hFont                                           As Long
Dim hFontOld                                        As Long
Dim SZ                                              As SIZE
 
    hDC = GetDC(lListhWnd)
    If CBool(hDC) = True Then
        hFont = SendMessage(lListhWnd, WM_GETFONT, &H0&, ByVal &H0&)
        hFontOld = SelectObject(hDC, hFont)
        
        If sText = vbNullString Then
            If GetTextExtentPoint32(hDC, CHARS_LIST, CHARS_LEN, SZ) Then
                PixelsPerUnit = CSng((2 * CLng(SZ.cX / CHARS_LEN)) / (GetDialogBaseUnits And &HFFFF&))
            End If
        Else
            If GetTextExtentPoint32(hDC, sText, Len(sText), SZ) Then
                PixelsPerUnit = (SZ.cX * Screen.TwipsPerPixelX)
            End If
        End If
        
        SelectObject hDC, hFontOld
        ReleaseDC lListhWnd, hDC
    End If
End Function
 
Private Sub Class_Initialize()
    Debug.Print "--> cListBoxMultiAlign.cls By Mr.Frog © <--"
End Sub

A picture is worth a thousand words:

[LaVolpe]

Mr. Frog. Good job, couple things...

1) If you add just enough right/center aligned items to fill up the listbox before a scrollbar appears then add 1 more item, left aligned, to force a scrollbar, your right align items are partially hidden by the scrollbar and centered items are no longer centered.

2) It should be noted that center aligned items are space padded, so if one needs to get the item from the listbox, they should remove any leading spaces. Same applies to right aligned items, user must strip the tab from the item

3) I don't think SendMessage with LB_FINDSTRING, LB_FINDSTRINGEXACT will work with your listbox implementation due to added leading characters

4) Not an issue per se, if someone changes the font of the listbox after items are loaded, alignment will go nuts. But who does that anyway?

[*PsyKE1*]

Really thanks for your opinion LaVolpe!
I have some questions for you:

1.-How i Know what is the last item before scrollbar appears?

2.-I thounght that it would be better like this:

'...
Private myListBox                                   As ListBox
Private lListhWnd                                   As Long
Private lWidth                                      As Long
 
Public Sub SetListBox(myList As ListBox)
    If Not (myList Is Nothing) Then
        Set myListBox = myList
        lListhWnd = myListBox.hWnd
        SetRightTab
    End If
End Sub
 
Public Sub AddAlignItem(ByVal Item As String, ByVal Align As AlignmentConstants, Optional ByVal Index As Long = (-1))
    If Index = (-1) Then Index = myListBox.ListCount
    
    Select Case Align
        Case vbRightJustify
            myListBox.AddItem vbTab & Item, Index
            If lWidth <> myListBox.Width Then SetRightTab
        Case vbCenter
            myListBox.AddItem Space$(Abs(Int(Int(Int(myListBox.Width - UnitPerPixels(Item))) / UnitPerPixels(Space$(1)) / 2) - 1.5)) & Item, Index
        Case Else
            myListBox.AddItem Item, Index
    End Select
End Sub
'...
Private Sub SetRightTab()
Dim RCT                                             As RECT
Dim lRightAlignTab                                  As Long
    
    lWidth = myListBox.Width
    
    GetClientRect lListhWnd, RCT
    With RCT
        lRightAlignTab = -((.Right - .Left) / UnitPerPixels)
    End With
    
    SendMessage lListhWnd, LB_SETTABSTOPS, 0&, ByVal 0&
    SendMessage lListhWnd, LB_SETTABSTOPS, 1&, lRightAlignTab
    myListBox.Refresh
End Sub
'...

Like this i wouldn't have to set tab everytime, only if the width of my listbox changes. But it return this:

your right align items are partially hidden by the scrollbar and centered items are no longer centered.

3.-And i can add function called "RefreshList" wich comprobe if the fontsize or fontbold... changes (it would be too ugly?)

4.-Why you don't like my GetRealItem() function to remove tabs and/or spaces?

It's all by now, thanks again friend!

[LaVolpe]

1.-How i Know what is the last item before scrollbar appears?
2.-I thounght that it would be better like this...

^^ Good idea.

3.-And i can add function called "RefreshList" wich comprobe if the fontsize or fontbold... changes (it would be too ugly?)

^^ Ugly, no. But can be time consuming if there are 1000s of items in the list

4.-Why you don't like my GetRealItem() function to remove tabs and/or spaces?

^^ That will work. Just didn't notice it because I wasn't looking for it.

Doing this using the VB listbox as-is, has its inherent problems. For small lists, it isn't a problem re-centering center aligned items when the scrollbar is added/removed, but large lists will be. If you had control over drawing the listbox, then things would be different and more efficient because you wouldn't have to re-align every list item, only the ones displayed. However, this requires subclassing and owner-drawing the listbox and would be an entire project on its own, not just a relatively simple class.

For large lists, the ability to search the listbox using LB_FINDSTRING & LB_FINDSTRINGEXACT is a huge advantage because it is very fast. By appending spaces & tabs to list items, one can no longer use the API to search. That, I think, is the biggest downside. Otherwise, good job and could be very useful for specific purposes.

One more item. You might want to test your centering routine for very long list items that would extend past the client rect

[*PsyKE1*]

I updated the code again.
Check it.

1.-I added SearchSimilarItem function which returns the index of the first similar/equal item (that's what you said I should do?)
Example:

MsgBox List1.List(LMA.SearchSimilarItem("verda")) ' It returns 'Verdana'

I did this funtion long ago: Check_SimilarWords
I may be able to deploy in some way.

2.-Finally I only check the Width becouse i would spend too time as you have said.

3.-I fixed this:

One more item. You might want to test your centering routine for very long list items that would extend past the client rect

4.-Now my last (I hope :P) problem is this:

your right align items are partially hidden by the scrollbar and centered items are no longer centered.

A solution may be this (but I don't like it ):

Chage this:

If Not (lWidth = myListBox.Width) Then SetRightTab

by this:

SetRightTab

I learn a lot with you, i hope your reply.. :P

[LaVolpe]

Your search won't work for center/right aligned items. Try it. Result is always -1 (failure)

    Dim c As New Class1
    c.SetListBox List1
    c.AddAlignItem "LaVolpe", vbCenter
    MsgBox c.SearchSimilarItem("LaVolpe")
    c.AddAlignItem "Mr.Frog", vbRightJustify
    MsgBox c.SearchSimilarItem("Mr.Frog")

Now regarding the width. Testing the width isn't the correct logic here I think. The width will only change when the physical size of the listbox changes, not when scrollbar is added/removed. But the client rect's .Right will change when scroll bar is added/removed or when the physical size of the listbox changes.

Here's an idea for that problem. When the listbox is first assigned, set lWidth = client rect's .Right member. After list items are added, check the client rect again and if the .Right <> lWidth then cache new lWidth and reset the right tab. This should work well except for removing items or someone resizing the listbox during runtime. You have no way to know if items are being removed or not or if listbox is resized. You can fix the remove problem by creating a function like RemoveItem. Regarding the changing of the listbox size... just a matter of the user being aware that they need to call some function (not yet created) of your class that will validate the tabs, specifically the right tab. And not much you can do about center aligned items other than looping thru each & every listbox item to add/remove a couple of spaces - time consuming for very large lists.

[*PsyKE1*]

Your search won't work for center/right aligned items. Try it. Result is always -1 (failure)

Oops! True
That's becouse the tabs and spaces... i can fix it...
I did this funtion long ago: Check_SimilarWords
I may be able to deploy in some way.


Now for me is late, i'll follow tomorrow, thanks for the time!

[*PsyKE1*]

I got it! : D
Using ClienRect!
Please see the code again, I have updated and improved.
Already corrected the problem with the ScrollBar.
In the end decided not to add the function SearchSimilarItem.
Try it when you can, I apologize for giving you a lot of work.
Thanks! : P

[*PsyKE1*]

sorry for the double post, my webbrowser it's crazy... ¬¬