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!