Test Foro de elhacker.net SMF 2.1

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!¡.

Cita de: BlackZeroX▓▓▒▒░░ en 15 Diciembre 2010, 01:27 AM
.
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:

Cita de: ssccaann43 en 15 Diciembre 2010, 14:42 PM
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