Ejemplos usando el Api de windows para Visual basic

182 - Agregar ScrollBar horizontal a un ListBox

Contenido

Ejemplo 1
Ejemplo 2
Relacionados

Ejemplo 1

Ejemplo que usa la función api SendMessage con el mensaje LB_SETHORIZONTALEXTENT, para poder añadir un ScrollBar horizontal a un ListBox

vista del formulario de ejemplo para aplicar scrollbar horizontal a los controles listbox

En este ejemplo , para aplicar el Scrolllbar al listbox, se le envía como parámetro a SendMessage lo siguiente

ret = SendMessage(" Hwnd del control Listbox ", Mensaje LB_SETHORIZONTALEXTENT, " Ancho del Scrollbar en pixeles ", " valor nulo ")

Para obtener el ancho del texto del item mas largo, se usa la función GetTextExtentPoint32 ( aunque se podría obviar esta función y utilizar la de vb )

Controles

Dos listbox
Un CommandButton

Código fuente en el formulario

Option Explicit Private Sub Command1_Click() ' Le agrega el Scrollbar a los dos listbox Call Aplicar_ScrollBar(List1) Call Aplicar_ScrollBar(List2) End Sub Private Sub Form_Load() Dim i As Integer 'Carga algunos datos en los controles List1.FontSize = 10 For i = 1 To 12 List1.AddItem i & " " & MonthName(i) & " de " & Year(Date) Next List2.FontSize = 16 For i = 1 To 12 List2.AddItem i & " " & MonthName(i) & " de " & Year(Date) Next Command1.Caption = " Aplicar Scrollbar " List1.Width = 1800 List2.Width = 1800 End Sub

Código fuente en un módulo bas

Option Explicit 'Declaraciones del Api ' Función que recupera el ancho y alto en pixeles _ de un texto a partir del dispositivo de contexxto indicado Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _ ByVal hDC As Long, _ ByVal lpsz As String, _ ByVal cbString As Long, _ lpSize As SIZE) As Long 'Estructura para usar con GetTextExtentPoint32 _ ( retorna el Ancho y alto en pixeles ) Private Type SIZE cx As Long cy As Long End Type ' Recupera el Hdc a partir del hwnd de un objeto Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long ' Función SendMessage para Establecer el ScrollBarHorizontal al listbox 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 ' Mensaje que usa SendMessage Private Const LB_SETHORIZONTALEXTENT = &H194 ' Sub que establece la barra de desplazamiento horizontal al listbox '****************************************************************************** Sub Aplicar_ScrollBar(ListBox As ListBox) Dim ret As Long Dim i As Integer ' Esta variable es la que se envia a _ SendMessage y le indica el ancho del Scrollbar Dim Ancho_Maximo As Long Dim Ancho_Texto As Long Dim Alto_Texto As Long 'Obtiene el ancho del texto del primer item ret = Obtener_Text_Size(ListBox, ListBox.List(i), Ancho_Texto, Alto_Texto) Ancho_Maximo = Ancho_Texto 'REcorre todos los items para ver cual es el mas ancho For i = 0 To ListBox.ListCount - 1 ret = Obtener_Text_Size(ListBox, ListBox.List(i), Ancho_Texto, Alto_Texto) If Ancho_Texto > Ancho_Maximo Then Ancho_Maximo = Ancho_Texto + 10 End If Next ' Aplica el scrollBar Horizontal ret = SendMessage(ListBox.hWnd, LB_SETHORIZONTALEXTENT, Ancho_Maximo, ByVal 0&) End Sub ' Función que retorna la anchura y altura en pixeles del texto '********************************************************************** Public Function Obtener_Text_Size(Objeto As Object, _ Texto As String, _ Ancho As Long, _ Height As Long) As Long ' Variables que almacenan las caracteristicas _ de la fuente del objeto contenedor del control pasado como parámetro Dim m_Font As String Dim m_FontSize As Integer Dim m_FontBold As Boolean Dim m_FontItalic As Boolean Dim m_FontUnderline As Boolean Dim Flag As Boolean Dim ret As Long Dim t_Size As SIZE Dim m_DC As Long Dim m_Hwnd As Long On Error Resume Next ' REcupera el hdc del objeto contenedor del control m_DC = Objeto.Parent.hDC ' Si hay un error, es por que el objeto no tiene hdc If Err.Number Then Err.Clear '.. entonces prueba a recuperar el hdc pero a partir del _ hwnd (m_DC = GetDC(m_Hwnd)) m_Hwnd = Objeto.Parent.hWnd If Err.Number Then Err.Clear 'Limpia el error Obtener_Text_Size = True Exit Function End If m_DC = GetDC(m_Hwnd) ' Recupera el Hdc End If ' Cambia la fuente del objeto contenedor With Objeto.Parent ' Almacena las propiedades para luego restaurarlas m_Font = .FontName m_FontSize = .FontSize m_FontBold = .FontBold m_FontItalic = .FontItalic m_FontUnderline = .FontUnderline 'asigna la fuente temporal .FontName = Objeto.FontName .FontSize = Objeto.FontSize .FontBold = Objeto.FontBold .FontItalic = Objeto.FontItalic .FontUnderline = Objeto.FontUnderline End With ' Le envia como parámetro el Hdc, el texto del item actual , el tamaño del texto, y _ la estructura t_Size retorna el ancho y alto en pixeles ret = GetTextExtentPoint32(m_DC, Texto, Len(Texto), t_Size) With t_Size Ancho = .cx Height = .cy End With On Error Resume Next If Flag Then 'Restaura la fuente original del objeto contenedor With Objeto.Parent .FontName = m_Font .FontSize = m_FontSize .FontUnderline = m_FontUnderline .FontBold = m_FontBold .FontItalic = m_FontItalic End With End If End Function

Ejemplo 2

Este otro código fuente es muy simple, y puede ser útil para cuando deseamos mostrar rutas y archivos en una lista, y luego de añadir los paths al control, poder aplicar la barra horizontal, y de este modo poder visualizar items donde el ancho sea superior al ancho que tenga el control. El ejemplo es igual al anterior, lo único que difiere es que utiliza la función TextWidth de vb, en vez de la función GetTextExtentPoint32, para poder obtener el ancho del texto, y luego con ese valor, poder enviárselo a SendMessage.

Agregar un botón y un listbox.

Código en el Form

Option Explicit ' ------------------------------------------------------------------------------------ ' \\ -- Sub para cargar las rutas + archivos en el control ListBox ' ------------------------------------------------------------------------------------ Private Sub LoadPaths(sPath As String, lBox As ListBox) Dim sFile As String If Right(sPath, 1) <> "\" Then sPath = sPath & "\" ' -- Listar con la función Dir de vb sFile = Dir(sPath & "\*.*") lBox.Clear While Len(sFile) lBox.AddItem sPath & sFile sFile = Dir Wend ' -- Aplicar ScrollBar horizontal y seleccionar el item mas largo de la lista Dim ret As Long ret = Aplicar_ScrollBar(lBox) If ret Then List1.ListIndex = ret End Sub ' ------------------------------------------------------------------------------------ ' \\ -- Botón para indicar un directorio y cargar el list ' ------------------------------------------------------------------------------------ Private Sub Command1_Click() Dim sPath As String sPath = InputBox("Escribir directorio para listar los archivos", , Environ("windir")) If Len(sPath) Then Call LoadPaths(sPath, List1) End Sub

Código fuente en un BAS

Option Explicit 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 Const LB_SETHORIZONTALEXTENT = &H194 Function Aplicar_ScrollBar(ListBox As ListBox) As Long Dim ret As Long Dim i As Integer Dim j As Long Dim Ancho_Maximo As Long Dim Ancho_Texto As Long Dim LBParent As Object Set LBParent = ListBox.Parent Ancho_Maximo = -1 j = -1 For i = 0 To ListBox.ListCount - 1 Ancho_Texto = LBParent.TextWidth(ListBox.List(i)) If Ancho_Texto > Ancho_Maximo Then Ancho_Maximo = Ancho_Texto + (10 * Screen.TwipsPerPixelX) j = i End If Next Set LBParent = Nothing ' -- Establecer el Scroll ret = SendMessage(ListBox.hWnd, LB_SETHORIZONTALEXTENT, (Ancho_Maximo / Screen.TwipsPerPixelX), ByVal 0&) ' -- retornar item mas largo Aplicar_ScrollBar = j End Function

Enlaces relacionados

Crear ScrollBar Horizontal a un ComboBox

Buscar en Recursos vb