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
Mostrar Temas
).
