Centrar texto en un Listbox

Una de las formas rápidas de centrar texto en un listbox, es insertando los espacios necesarios al ítem. La forma de calcular el tamaño de un texto lo puedes hacer sin API con un label en autosize. El problema son los varios píxeles que ocupa un espacio, y por eso, la alineación a veces puede ser un poco imprecisa a primera vista.
Este código permite alinear el texto aproximadamente 4 veces más que el comentado. Al final del todo, añado algunas notas importantes de este código.

Actualmente estoy preparando otro código, otra forma distinta de obtener texto centrado. Ya tengo la idea pero aún tardaré algún tiempo.

Explicación del código:

La idea que se me ocurrió para este código es utilizar los tabuladores junto con sendmessage. Tras acabarlo por primera vez, lo reanalicé para disminuir en todo lo posible el código y así quedó.
Para insertar un ítem centrado, solamente hay que llamarlo así: Centrar (Listbox, String). He de decir que todo el código es original, excepto la Función UnidadporPixel que ya la había utilizado en otros códigos e ignoro su procedencia.

Solamente se necesita un Form con un Listbox: list1 y un módulo. El código lo he dejado bien explicado.

Código en el módulo:

Option Explicit
'*******************************************************************************'
'**                  MÓDULO PARA CENTRAR TEXTO EN UN LISTBOX                  **'
'**                                                                           **'
'**               Para añadir un ítem: Centrar(Listbox, String)               **'
'**                       Realizado por karmany (2006)                        **'
'**                         No borre esta cabecera.                           **'
'**                       email: [email protected]                         **'
'*******************************************************************************'

'Declaraciones API---------------------------------------------------------------
Private Declare Function GetDialogBaseUnits Lib "user32.dll" () As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal HDC As Long, _
                                            ByVal hObject As Long) As Long  

Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias _
                       "GetTextExtentPoint32A" (ByVal HDC As Long, ByVal _
                       lpString As String, ByVal cbString As Long, ByRef _
                       lpSize As SIZE) 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 ReleaseDC Lib "user32.dll" (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

'Estructuras---------------------------------------------------------------------
Private Type SIZE
   cx As Long
   cy As Long
End Type
'Private Type RECT
  'Left As Long
  'Top As Long
  'Right As Long
  'Bottom As Long
'End Type

'Variables y constantes----------------------------------------------------------
Private tabs(10) As Long, texto(10) As String, tabs2(10) As Long, pos(10) As Integer
Private i As Integer, inf As Integer, sup As Integer
Private cantidad As Integer, cantidad2 As Integer
Private Const WM_GETFONT As Long = &H31&
Private Const LB_SETTABSTOPS As Long = &H192
Private Const Cadena = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
'*******************************************************************************'


Public Sub Centrar(LB As ListBox, text As String)
    
   Dim U As Single, resultado As Single, tamtext As Long, tamlist As Single
   Dim ParentForm As Form
   'Dim rc As RECT
    
   'Esta es la limitación que pongo: máximo 10 ítems..Si quieres utilizar más
   'de 10, deberás modificar el sencillo código. Ante alguna duda está mi
   'correo arriba.
   cantidad = LB.ListCount + 1
   If cantidad = 11 Then
       MsgBox "No puedes agregar más de 10 Ítems..." & vbCrLf & _
       "Deberás modificar antes algo de código." & vbCrLf & _
       "Es sencillo... :-)", vbInformation, "No se permite agregar más Ítems:"
       Exit Sub
   End If
    
   Set ParentForm = LB.Parent
    
   'El problema de los tabuladores es que hay que poner la distancia
   'en unidades de diálogo:
   U = UnidadporPixel(LB.hwnd)
    
   'Calcula el tamaño del texto:
   tamtext = Fix(calculatamaño(LB.hwnd, text) / U)
    
   'Calcula el tamaño del ancho del listbox:
   tamlist = ParentForm.ScaleX(LB.Width, ParentForm.ScaleMode, vbPixels)
   tamlist = Fix((tamlist / U) - 1)
   'Otra forma de obtener el ancho del Listbox es esta:
   'Call GetClientRect(LB.hwnd, rc)
   'Dim a As Single
   'a = (rc.Right) / U
    
    
   'Calcula el tamaño del tabulador y lo guarda:
   resultado = (tamlist - tamtext) / 2
   tabs(cantidad) = resultado
    
   'Guarda el texto en el array:
   texto(cantidad) = text
    
   'Borra todos los tabs y el listbox:
   LB.Clear
   Call SendMessage(LB.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
    
   'La call ordenar() ordena los tabs de menor a mayor en tabs2(),
   'después dejará sólo un item repetido y por último calculará el
   'orden de tabulador a cada item.
   Call ordenar
    
   'Ahora introduzco de nuevo todos los elementos al listbox:
   For i = 1 To cantidad
       LB.AddItem (vbTabs(pos(i)) + texto(i))
   Next i

   'Hay que devolverle además los tabs ordenados de menor a mayor, por
   'eso tabs2().
   Call SendMessage(LB.hwnd, LB_SETTABSTOPS, cantidad2, tabs2(1))
    
   Set ParentForm = Nothing
End Sub
'-------------------------------------------------------------------------------'
Private Function calculatamaño(ByVal hwnd As Long, texto2 As String) As Single
   'Esta función devuelve el tamaño del texto a centrar
   Dim hfuente As Long, Lfuente As Long, tamaño As SIZE
   Dim HDC As Long
    
   HDC = GetDC(hwnd)
   If HDC = 0 Then Exit Function
        
   hfuente = SendMessage(hwnd, WM_GETFONT, 0&, ByVal 0&)
   Lfuente = SelectObject(HDC, hfuente)
        
   If GetTextExtentPoint32(HDC, texto2, Len(texto2), tamaño) <> 0 Then
       calculatamaño = tamaño.cx 'Devuelve el tamaño
   End If
        
   Call SelectObject(HDC, Lfuente)
   Call ReleaseDC(hwnd, HDC)
    
End Function
'-------------------------------------------------------------------------------'

Private Function UnidadporPixel(ByVal hwnd As Long) As Single
    
   Dim DBU As Single, hfuente As Long, Lfuente As Long, tamaño As SIZE
   Dim Anchocaracter As Single
   Dim HDC As Long
    
   HDC = GetDC(hwnd) 'HDC  = Handle al Dispositivo de Contexto
                     'hwnd = listbox.hwnd
    
   If HDC = 0 Then Exit Function 'GetDC devuelve NULL si hay error
        
   'Recupera la fuente con la cual el control está dibujando el texto.
   hfuente = SendMessage(hwnd, WM_GETFONT, 0&, ByVal 0&)
    
   Lfuente = SelectObject(HDC, hfuente)
        
   'Calcula la anchura de la cadena de texto especificada.
   If GetTextExtentPoint32(HDC, Cadena, Len(Cadena), tamaño) <> 0 Then
       Anchocaracter = tamaño.cx / Len(Cadena) 'Promedio por carácter

       DBU = GetDialogBaseUnits And &HFFFF& 'Unidad de diálogo
       UnidadporPixel = (2 * Anchocaracter) / DBU
   End If
        
   Call SelectObject(HDC, Lfuente)
   Call ReleaseDC(hwnd, HDC) 'Tras GetDC hay que acabar con ReleaseDC para
                             'liberarlo
    
End Function
'-------------------------------------------------------------------------------'
Private Function vbTabs(num As Integer) As Variant
   'Número de tabuladores.
   Dim h As Integer
   vbTabs = ""
   For h = 1 To num
       vbTabs = vbTabs + vbTab
   Next h
End Function
'-------------------------------------------------------------------------------'
Private Sub ordenar()
   Dim po As Integer
   'Pasa todos los datos de tabs() a tabs2()
   For i = 1 To cantidad
       tabs2(i) = tabs(i)
   Next i
    
   'Los ordena de menor a mayor:
   inf = 1: sup = cantidad
   While inf < cantidad
   While sup >= inf + 1
       Call orden
   Wend
   inf = inf + 1: sup = cantidad
   Wend
    
   'Ahora hay que comprobar los repetidos y dejar sólo uno:
   cantidad2 = cantidad
   Dim p As Integer
   For i = 1 To cantidad2 - 1
       If i >= cantidad2 Then Exit For '<--Parece q esto no es necesario
       If tabs2(i) = tabs2(i + 1) Then '   pero sí lo es..
           For p = i + 1 To cantidad2 - 1
               tabs2(p) = tabs2(p + 1)
           Next p
           tabs2(cantidad2) = 0: cantidad2 = cantidad2 - 1: i = i - 1
       End If
   Next i
   'Ejemplo hasta aquí:
   'Datos ordenados: 2,10,23,23,23
   'Ahora:           2,10,23
   'Es decir, ahora ya están los tabs y el número que hay que
   'poner en sendmessage, y ordenados de menor a mayor..
    
   'Ahora sólo queda averiguar cuales son los tabs que se repiten y cuándo:
   For i = 1 To cantidad
       For p = 1 To cantidad2
           If tabs(i) = tabs2(p) Then pos(i) = p
       Next p
   Next i

End Sub
'-------------------------------------------------------------------------------'
Private Sub orden()
   Dim temp As Integer
   For sup = sup To inf + 1 Step -1
       If tabs2(inf) > tabs2(sup) Then
           temp = tabs2(inf)
           tabs2(inf) = tabs2(sup)
           tabs2(sup) = temp
           Exit For
       End If
   Next sup
End Sub

Código en el formulario:

Option Explicit

Private Sub Form_Load()
    With List1
        .Height = 1680
        .Left = 1080
        .Top = 240
        .Width = 5640
        .FontName = "Arial"
        .FontSize = 12
    End With
    With Form1
        .Height = 2685
        .Width = 7950
    End With
        
    'Esta es la forma de 'additem' ítems:
    'Centrar (nombre del listbox, string a insertar):
    Call Centrar(List1, "Texto centrado")
    Call Centrar(List1, "Listbox")
    Dim i As Integer, s As String
    For i = 1 To 72
        s = s + "-"
    Next i
    Call Centrar(List1, s)
    Call Centrar(List1, "para Guille")
    Call Centrar(List1, "de karmany.")
    List1.ListIndex = 2
    
End Sub

Observaciones:
Después de analizar y probar detenidamente el código, pude comprobar, que algunos tipos de letra y a determinados tamaños, dan un ligerísimo desplazamiento del centro. Esto es así porque el resultado que devuelve el ancho del Listbox no es preciso. Si habéis visto el código, también probé calcular el ancho del listbox con GetClientRect, pero el resultado es idéntico. Entonces, ¿tal vez el resultado erróneo venga desde GetTextExtentPoint32..??

Todo esto viene, por si alguien quiere poner un título centrado. Mi consejo es que no utilices un Label y lo centres, ya que, se puede calcular la posición exacta de dónde debe ir el título. Simplemente hay que calcular como si fuese un ítem más y tener en cuenta el Left del Listbox, si no sabes cómo hacerlo házmelo saber, es sencillo.
Otra cosa que habréis visto, me imagino, es que solamente se pueden añadir 10 ítems. ¿Por qué?, porque pienso que así echarás un vistazo al código, no todo lo voy a hacer yo. Es muy sencillo modificarlo.

Ejecutando el código anterior debe salirte esto:

Para cualquier duda, aclaración, error, comentario, dejo en el encabezado mi correo. También podéis encontrarme en:
http://foro.elhacker.net/

Salu2