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
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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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
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.
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(Opti onal 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_CXBOR DER) * 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_CXBOR DER) * 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
====
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(Opti
'// 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
'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_CXBOR
'// 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_CXBOR
'// 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(
If Not pIsListAttached() Then Exit Sub
pUpdateHorizScrollbar
End Sub
hth.