[SRC] cListBoxMultiAlign [by Mr. Frog ©]

[Psyke1]

Os dejo mi ultima clase que sirve para justificar texto en un ListBox, la novedad es que puedes actuar sobre especificamente con cada Item, dejo el código:

Código: (vb) [Seleccionar]

Option Explicit
'==================================================================================================
' º Class     : MultiAlignListBox.cls
' º Version   : 1.1
' º Author    : Mr.Frog ©
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º 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
Una imagen vale mas que 1000 palabras:

DoEvents!

[DarkStreaM]

Wooo!!
Muchas gracias 

[ssccaann43]

Permitame felicitarlo señor ranita, esta usted muy comprometido con el VB y eso me agrada...! Pensare menos en ANCAS y continuare trabajando..!

[Psyke1]

Gracias, pero aun quedan cosas por resolver... :S Hay algun bug por hi escondido, y creo que podre optimizar un poco mas el codigo...
Tambien se me ocurrio esta forma de centrar el texto sin Apis y sin agregar controles adicionales, aunque es un poco fea (pero funciona :silbar:) :

En un módulo:

Código: (vb) [Seleccionar]

Option Explicit
'=========================================================
' º Function : AlignCenterLBItem
' º Author   : Mr.Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Greets   : LeandroA
' º Recommended Websites :
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'       http://twitter.com/#!/PsYkE1
'=========================================================

Public Function AlignCenterLBItem(myListbox As ListBox, ByVal sItem As String) As String
Dim lItemLen                                           As Long
    If Not (myListbox Is Nothing) Then
        lItemLen = myListbox.Parent.TextWidth(sItem)
        If lItemLen < myListbox.Width Then
            AlignCenterLBItem = Space$(Abs(Int((Int(myListbox.Width - lItemLen) / 2) / myListbox.Parent.TextWidth(Space$(1)) - 1.5))) & sItem
        End If
    End If
End Function
Ej:

Código: (vb) [Seleccionar]

Private Sub Form_Load()
    List1.AddItem AlignCenterLBItem(List1, "Amo a LeandroA el gallo ¬¬""")
End Sub

Es la forma más corta que e visto...

DoEvents!

[LeandroA]

Todo bien pero es un Gallo no un Pollo 

una cosita nada mas que vi, en vez de usar With Forms(0) usas With myListbox.Parent, digo esto porque podria ejecutarse desde otro form con distinta fuente (algo muy volado pero bueno me parece mas correcto)

Saludos.

[Psyke1]

Gracias amigo, una cosa más que sé... ya corregi el ejemplo anterior (incluso cambie lo de "pollo")
En cuanto a la clase, en unos dias, la resubo optimizada.

DoEvents!