Foro de elhacker.net

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:

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 & Karmany
' º 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! :P

Muy Bien  ;-) ;-) ;-)

.
Bonito

P.D.: casi no le ponias la referencia ¬¬"

Dulces Lunas!¡.

Gracias! ;)
:xD
Ya la puse, y ya avise a karmany por MP para que le heche un vistazo!  ;D

DoEvents! :P

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:

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

Ejemplo:

Private Sub Form_Load()
    List1.AddItem AlignCenterLBItem(List1, "Amo elhacker.net")
End Sub

:xD

Es lo más corto que he visto...  ::)

DoEvents! :P

HOLA!!!

Muy bueno!!!
Lo que quisiera saber es si se puede hacer un Item Multiline.

GRACIAS POR LEER!!!

Si se puede, BlackZerox y Ranita saben...!  :silbar:

:xD
Pues creo que esta vez te equivocas... :rolleyes:

@79137913
Eso no será sencillo, para ello puedes buscar algun UC (despues busco y posteo si encuentro algo), o quizas se pueda hacer algo con otro control; un LV o un MSFLGRND (no lo se :-\).
Tengo aun que mejorar esta clase que tiene algun bug por ahi... Despues actualizo.

DoEvents! :P

Se puede hacer con un UC...! Pero con el List normal, sinceramente lo dificulto..! BlackZerox anda ya creando controles List y ListView con excelentes bondades y muy bonitos esteticamente,  :¬¬ "aunque aveces la gran mayoria de sus colores inframundos son negros" jaja  :xD

Pero igual se que el sabe sobre ese tema..!

PD: Ranita no te hagas de rogar, vos sabes como es...!  :silbar:

Excelente código Mr. Frog.
Con tu mp me basta, por mi no hace falta que me incluyas en el membrete de tu código pues lo has hecho tú todo...

Lo he probado y ahora no tengo tiempo para analizarlo pero no alinea bien a la derecha (VB6 - Windows XP SP3):
(http://img89.imageshack.us/img89/6396/86043910.png)

@karmany
En eso estoy trabajando en un rato pongo el SRC optimizado!  ;)

DoEvents! :P

Aqui está, bug reparados y código optimizado  :)

DoEvents! :P