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

Option Explicit
'=========================================================
' º Function : AlignListBox
' º Author   : Mr. Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Recommended Websites :
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'       http://twitter.com/#!/PsYkE1
'=========================================================
 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
Private Const GWL_EXSTYLE                       As Long = (-20)
Private Const WS_EX_RIGHT                       As Long = &H1000&
Private Const WS_EX_LEFT                        As Long = &H0&
Private Const WS_EX_LEFTSCROLLBAR               As Long = &H4000&
Private Const WS_EX_RIGHTSCROLLBAR              As Long = &H0&
 
Public Enum AlignConstants
   aLeft = 0
   aRight = 1
End Enum
 
Public Enum OptionAlign
   Items = 0
   ScollBar = 1
End Enum
 
Public Function AlignListBox(ByVal myListBox As ListBox, _
                               ByVal ThingToAlign As OptionAlign, _
                               Optional ByVal Align As AlignConstants = aLeft) As Long
Dim lStyle                                              As Long
Dim lHwnd                                               As Long
    If Not (myListBox Is Nothing) Then
        lHwnd = myListBox.hwnd
        lStyle = GetWindowLong(lHwnd, GWL_EXSTYLE)
        If Align = aRight Then
            If ThingToAlign = Items Then
                lStyle = lStyle Or WS_EX_RIGHT
            Else
                lStyle = lStyle And WS_EX_RIGHTSCROLLBAR
            End If
        Else
            If ThingToAlign = Items Then
                lStyle = lStyle And WS_EX_LEFT
            Else
                lStyle = lStyle Or WS_EX_LEFTSCROLLBAR
            End If
        End If
        AlignListBox = SetWindowLong(lHwnd, GWL_EXSTYLE, lStyle)
    End If
End Function

Option Explicit
 
Private Sub Form_Load()
Dim Q                               As Long
    For Q = 0 To (Screen.FontCount - 1)
        List1.AddItem Screen.Fonts(Q)
    Next Q
 
    AlignListBox List1, Items, aRight
    'AlignListBox List1, Items, aLeft
    AlignListBox List1, ScollBar, aLeft
    'AlignListBox List1, ScollBar, aRight
End Sub

Option Explicit
 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
Private Const GWL_STYLE                 As Long = (-16)
Private Const WS_CAPTION                As Long = &HC00000
 
Private Function BorderStyleNone(ByVal bValue As Boolean) As Long
Dim lStyle                              As Long
    lStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
    If bValue Then
        lStyle = lStyle Xor WS_CAPTION
    Else
        lStyle = lStyle Or WS_CAPTION
    End If
    BorderStyleNone = SetWindowLong (Me.hWnd, GWL_STYLE, lStyle)
End Function
 
Private Sub Form_Activate()
    Call BorderStyleNone(True)
End Sub