Link to home
Start Free TrialLog in
Avatar of mpltech
mpltech

asked on

VB5 listbox with horizontal scroll

Hey folks

just like the title says, I'm looking for a free VB5 control that works like an ordinary list box but can scroll both ways..sounds ridiculously easy but it is evading me.

Also a file list box would be nice.

Mike
ASKER CERTIFIED SOLUTION
Avatar of wileecoy
wileecoy
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
btw - this should also work with a FileListBox.

hth.
Avatar of mpltech
mpltech

ASKER

bingo

they do state, however, that it can't be used for file list boxes. In fact they say there's no way to do that. But that part is not that important, since I can now make the file list wider and the list box, which is for complete paths, narrower.

I actually downloaded a control (newex explorer list) which for the most part works great, has horizontal scroll bars, and lets you show large icons, small icons or details just like explorer. But OLE drag-drop doesn't appear to work properly, it only returns the first file selected.

I may post another question later for this...


Mike



If you do post another, include the link to the control so the experts can have a working copy.

Nice pickup on the filelistbox.  I hadn't noticed that until you mentioned it.

Thanks!

Wileecoy.
Better way of adding a horizontal scrollbar to a listbox
====

Hi!

I have come up with a better way of adding a horizontal scrollbar to the listbox. It is a class module that attaches itself to one listbox. The nice thing is that it also handles RemoveItem, procedure List(Index), Clear procedures and provides the same interface as the standard listbox. The class can be easily changed to attach itself to a window handle instead of a listbox reference.

The class also handles font changes so that any change of the listbox's font will update the horizontal scrollbar.

I have not tested it with listboxes that have tabstops set, if you can do it, please email me with the results. I think that the class will not quite work in this style, so if you figure out how to make it work, I'll be happy to learn from you.

The code is partially based on C++ code from CodeProject web site.

Best regards,
Stanislav

===

'Save as CHorizontalScrollLB

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CHorizontalScrollLB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_SETHORIZONTALEXTENT = &H194
'Private Const SM_CXVSCROLL = 2
Private Const SM_CXBORDER = 5

Private Type SIZEL
    cx As Long
    cy As Long
End Type
Private Const WM_GETFONT = &H31
Private Const API_NULL As Long = 0
Private Const GDI_ERROR = &HFFFF

Private Declare Function SelectObject Lib "gdi32" _
                        (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZEL) As Long

Private WithEvents m_ListboxFont As StdFont
Private m_LongestItemWidth As Long
Private m_Listbox As ListBox

Public Property Get List(ByVal Index As Integer) As String
    If Not pIsListAttached() Then Exit Property
   
    List = m_Listbox.List(Index)
End Property
Public Property Let List(ByVal Index As Integer, ByVal sText As String)
    If Not pIsListAttached() Then Exit Property
   
    m_Listbox.List(Index) = sText
    pUpdateHorizScrollbar
End Property

Public Sub Clear()
    If Not pIsListAttached() Then Exit Sub
   
    m_Listbox.Clear
    SendMessage m_Listbox.hWnd, LB_SETHORIZONTALEXTENT, 0, ByVal 0&
    m_LongestItemWidth = 0
End Sub

Public Sub RemoveItem(ByVal Index As Integer)
    If Not pIsListAttached() Then Exit Sub

    m_Listbox.RemoveItem Index
   
    pUpdateHorizScrollbar
End Sub

Public Sub AddItem(ByVal sItem As String, Optional Index As Variant)
    If Not pIsListAttached() Then Exit Sub

    pUpdateHorizScrollbar sItem

    m_Listbox.AddItem sItem, Index
End Sub

Public Function AttachLB(ByRef oList As ListBox)
If Not (oList Is Nothing) Then
    Set m_Listbox = oList
    Set m_ListboxFont = oList.Font
End If
End Function

Public Sub UpdateScrollbar()
    If Not pIsListAttached() Then Exit Sub
   
    pUpdateHorizScrollbar
End Sub

' ***********************************************************************
' Private
' ***********************************************************************

Private Sub pUpdateHorizScrollbar(Optional ByVal sItem As String = "")

'// If sItem is passed, update the scrollbar only if necessary, otherwise
'// loop through all items and update to the longest entry
Dim slTextSize As SIZEL
Dim lNewWidth As Long
Dim lMaxWidth As Long
Dim hDC As Long
Dim lFont As Long
Dim lFontOld As Long
Dim iListCount As Long
Dim i As Long

'Debug.Print "CHorizontalScrollLB: AddItem '" & sItem & "'"
hDC = GetDC(m_Listbox.hWnd)

Debug.Print "hDC = " & hDC

If hDC <> 0 Then
    '// We must select the font
    lFont = SendMessage(m_Listbox.hWnd, WM_GETFONT, 0, ByVal 0)
   
    'Debug.Print "lFont = " & lFont
   
    If lFont <> API_NULL Then
        lFontOld = SelectObject(hDC, lFont)
   
        If (lFontOld = 0) Or (lFontOld = GDI_ERROR) Then Exit Sub
        'Debug.Print "lFontOld = " & lFontOld
       
        If Len(sItem) > 0 Then
            '// Determine the item length in pixels
            GetTextExtentPoint32 hDC, sItem, Len(sItem), slTextSize
            '// Add fudge factor
            lNewWidth = slTextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 3)
            '// Add horizontal scrollbar only if necessary
           
            'Debug.Print "New item width is " & lNewWidth, "Longest: " & m_LongestItemWidth
           
            If lNewWidth > m_LongestItemWidth Then
                SendMessage m_Listbox.hWnd, LB_SETHORIZONTALEXTENT, lNewWidth, ByVal 0&
                m_LongestItemWidth = lNewWidth
               
                'Debug.Print "CHorizontalScrollLB: New item's width is " & m_LongestItemWidth
            End If
        Else
            iListCount = m_Listbox.ListCount
            lMaxWidth = 0
            If iListCount > 0 Then
                For i = 0 To iListCount - 1
                    '// determine item width
                    GetTextExtentPoint32 hDC, m_Listbox.List(i), Len(m_Listbox.List(i)), slTextSize
                    '// add fudge factor (for vertical scrollbar, etc)
                    lNewWidth = slTextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 3)
                    '// determine the length of the longest entry
                    If lNewWidth > lMaxWidth Then
                        lMaxWidth = lNewWidth
                    End If
                Next i
            End If
           
            '// update the horizontal scrollbar
            SendMessage m_Listbox.hWnd, LB_SETHORIZONTALEXTENT, lMaxWidth, ByVal 0&
            m_LongestItemWidth = lMaxWidth
        End If
       
        '// Restore original font, delete object
        SelectObject hDC, lFontOld
        ReleaseDC m_Listbox.hWnd, hDC
    End If
End If

End Sub

Private Function pIsListAttached() As Boolean
    pIsListAttached = Not (m_Listbox Is Nothing)
End Function

Private Sub Class_Terminate()
Set m_Listbox = Nothing
Set m_ListboxFont = Nothing
End Sub

Private Sub m_ListboxFont_FontChanged(ByVal PropertyName As String)
If Not pIsListAttached() Then Exit Sub

pUpdateHorizScrollbar
End Sub