Environment: VB4(32bit), VB5, VB6
The attached code contains a class that can be used to manipulate (add, remove or change caption) items in the ListBox control; when you add/remove/change an item, it adds or hides the horizontal scroll bar if required. Optionally it can scroll down the list box so you can see the last added item.
The code uses the SendMessage API function to add a horizontal scroll bar dynamically to a list box using the LB_SETHORIZONTALEXTENT message. To precisely calculate the width of a new item, our class uses the DrawText API function with the DT_CALCRECT flag. Draw attention at the fact that our class works properly if you change the font of the listbox as you want. We use the IFont interface and its hFont property to retrieve the handle of the font used in the listbox. Our class can also calculate the minimum width of the list box when the horizontal scroll bar disappears (it takes into account the visibility of the vertical scroll bar in the listbox; it determines whether this scroll bar is present by retrieving the listbox style flags and testing these set of flags for WS_VSCROLL).
Using of this class called CListBoxHScroll in real-world applications is very easy. All you need to do is to initialize this class using the Attach method which accepts the reference to the list box you want to populate. Then you can add/remove or change item caption using its methods (AddItem, RemoveItem and so on - like in the standard ListBox control).
To see how this class works, create a new exe project in VB and place the CommandButton and ListBox controls on its form. Don't change the default names of these controls (Command1 and List1 respectively). Put the following code in the Command1_Click event procedure:
Private Sub cmdPopulate_Click()
Dim LBHS As New CListBoxHScroll
Dim i As Long, lStrLen As Long
With List1.Font
.Name = "Arial"
.Size = 12
.Italic = True
End With
LBHS.Attach List1
For i = 1 To 30
lStrLen = Int(Rnd * 50) + 1
LBHS.AddItem String(lStrLen, "W") + "!"
Next
End Sub
Run the project and press the Command1 button. You will see that the listbox named List1 has been populated with 30 random length strings, has the horizontal scroll bar and displays the last added string.
The attached class can be useful in many real-world situations. For instance, if you perform context search in files, you can use this class to add found files to a list box at the screen as they are found. Our company uses this code in demo applications of the xDir library that allows you to enumerate files and folders in a specified folder and all of its subfolders using various filter criteria (file and folder mask; file size; attributes; date and time of creation, last access and modification, etc.) You can visit our Web-site (www.10Tec.com) to download this and other demos to see how it works.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "CListBoxHScroll"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const ITEM_MARGIN = 4
Private Const CHECKBOX_WIDTH = 14
' --- required API declarations ---
Private Declare Function SendMessageByLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const WM_VSCROLL = &H115
Private Const SB_BOTTOM = 7
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 DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_CALCRECT = &H400
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_VSCROLL = &H200000
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXVSCROLL = 2
' --- private class variables ---
Private mvarListBox As ListBox
Private m_lMaxItemWidth As Long
Private m_hItemFont As Long
Private m_ListBoxHwnd As Long
' Call this sub before you will use other methods of this class
Public Sub Attach(ByRef pListBox As ListBox)
Dim FontInt As IFont
Set mvarListBox = pListBox
m_ListBoxHwnd = mvarListBox.hwnd
' Determining the handle of the font used in the specified listbox.
' Using the IFont interface we can retreive the handle of the font
' used in the specified listbox.
' We'll use this handle further when we'll calculate the width of
' listbox items
Set FontInt = pListBox.Font
m_hItemFont = FontInt.hFont
End Sub
' The following routine adds a string to a specified list box
' and displays the horizontal scroll bar in it if required
Public Sub AddItem(ByRef psItemText As String, Optional ByVal pbScrollBottom As Boolean = True)
Dim lItemWidth As Long
mvarListBox.AddItem psItemText
' --- calculating the width of the currently added item ---
lItemWidth = flGetItemWidth(psItemText)
' --- determining whether we need to display the horizontal scroll bar ---
If lItemWidth > m_lMaxItemWidth Then
m_lMaxItemWidth = lItemWidth
pSetHorExtent
End If
' --- scrolling the listbox to be sure that the user see the last item ---
If pbScrollBottom Then
SendMessageByLong m_ListBoxHwnd, WM_VSCROLL, SB_BOTTOM, 0
End If
End Sub
Public Sub Clear()
mvarListBox.Clear
m_lMaxItemWidth = 0
SendMessageByLong m_ListBoxHwnd, LB_SETHORIZONTALEXTENT, 0, 0
End Sub
' Use this write-only property to change the caption of a list box item
Public Property Let List(ByVal piIndex As Integer, psItemText As String)
Dim lPrevItemWidth As Long
Dim lNewItemWidth As Long
lPrevItemWidth = flGetItemWidth(mvarListBox.List(piIndex))
mvarListBox.List(piIndex) = psItemText
lNewItemWidth = flGetItemWidth(psItemText)
If lPrevItemWidth = m_lMaxItemWidth Then
If lNewItemWidth > lPrevItemWidth Then
m_lMaxItemWidth = lNewItemWidth
pSetHorExtent
Else
RefreshHScroll
End If
Else
If lNewItemWidth > m_lMaxItemWidth Then
m_lMaxItemWidth = lNewItemWidth
pSetHorExtent
End If
End If
End Property
Public Sub pSetHorExtent()
SendMessageByLong m_ListBoxHwnd, LB_SETHORIZONTALEXTENT, _
m_lMaxItemWidth + ITEM_MARGIN + IIf(mvarListBox.Style = vbListBoxCheckbox, CHECKBOX_WIDTH, 0), 0
End Sub
Public Sub RemoveItem(ByVal piIndex As Integer)
Dim lItemWidth As Long
lItemWidth = flGetItemWidth(mvarListBox.List(piIndex))
mvarListBox.RemoveItem piIndex
If mvarListBox.ListCount = 0 Then
m_lMaxItemWidth = 0
SendMessageByLong m_ListBoxHwnd, LB_SETHORIZONTALEXTENT, 0, 0
Exit Sub
End If
If lItemWidth = m_lMaxItemWidth Then
' we remove the item with the maximum width
' and must recalculate the maximum width and the
' horizontal extent of our list box
RefreshHScroll
End If
End Sub
' recalculates the maximum width for all items and
' displays the horizontal scroll bar if required
Public Sub RefreshHScroll()
Dim hdc As Long
Dim rc As RECT
Dim hOldFont As Long
Dim i As Integer
Dim lItemWidth As Long
' We use the same technique like in the flGetItemWidth function,
' but sligtly optimize it: we don't need to select/deselect the
' required font for each item - we can do it at once outside the cycle
hdc = GetDC(m_ListBoxHwnd) ' retrieving HDC for the listbox
hOldFont = SelectObject(hdc, m_hItemFont) ' selecting the required font
m_lMaxItemWidth = 0
For i = 0 To mvarListBox.ListCount - 1
DrawText hdc, mvarListBox.List(i), -1, rc, DT_SINGLELINE + DT_CALCRECT
lItemWidth = rc.Right - rc.Left
If lItemWidth > m_lMaxItemWidth Then
m_lMaxItemWidth = lItemWidth
End If
Next
' restoring the previous font
Call SelectObject(hdc, hOldFont)
ReleaseDC m_ListBoxHwnd, hdc
pSetHorExtent
End Sub
Private Function flGetItemWidth(psItemText As String)
Dim hdc As Long
Dim rc As RECT
Dim hOldFont As Long
hdc = GetDC(m_ListBoxHwnd) ' retrieving HDC for the listbox
hOldFont = SelectObject(hdc, m_hItemFont) ' selecting the required font
' if you specify the DT_CALCRECT flag,
' DrawText only Determines the width and height of the rectangle
' required to display the text:
DrawText hdc, psItemText, -1, rc, DT_SINGLELINE + DT_CALCRECT
flGetItemWidth = rc.Right - rc.Left
' restoring the previous state
Call SelectObject(hdc, hOldFont)
ReleaseDC m_ListBoxHwnd, hdc
End Function
' Returns the minimum width of the list box
' when the horizontal scroll bar disappears
' NOTE: the return value in pixels
Public Property Get MinWidthNoHScroll() As Long
Dim bHasVScrBar As Boolean
bHasVScrBar = GetWindowLong(m_ListBoxHwnd, GWL_STYLE) And WS_VSCROLL
MinWidthNoHScroll = m_lMaxItemWidth + IIf(bHasVScrBar, GetSystemMetrics(SM_CXVSCROLL), 0) + _
IIf(mvarListBox.Style = vbListBoxCheckbox, CHECKBOX_WIDTH, 0) + _
ITEM_MARGIN + 4
End Property
VERSION 5.00
Begin VB.Form Form1
Caption = "ListBoxHScroll Class Demo"
ClientHeight = 5100
ClientLeft = 60
ClientTop = 345
ClientWidth = 6885
LinkTopic = "Form1"
ScaleHeight = 5100
ScaleWidth = 6885
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtItemCnt
Height = 315
Left = 1440
TabIndex = 8
Text = "50"
Top = 180
Width = 615
End
Begin VB.CommandButton cmdRemoveHScr
Caption = "Change the form width to remove the horizontal scroll bar"
Height = 855
Left = 120
TabIndex = 7
Top = 4080
Width = 1815
End
Begin VB.CommandButton cmdConnect
Caption = "Connecting to the populated listbox"
Height = 555
Left = 120
TabIndex = 6
Top = 3360
Width = 1815
End
Begin VB.CommandButton cmdChangeCap
Caption = "Change caption of the last item"
Height = 555
Left = 120
TabIndex = 5
Top = 2640
Width = 1815
End
Begin VB.CommandButton cmdAddItem
Caption = "Add item"
Height = 375
Left = 120
TabIndex = 4
Top = 1140
Width = 1815
End
Begin VB.CommandButton cmdClear
Caption = "Clear"
Height = 375
Left = 120
TabIndex = 3
Top = 2100
Width = 1815
End
Begin VB.CommandButton cmdRemoveLast
Caption = "Remove the last item"
Height = 375
Left = 120
TabIndex = 2
Top = 1620
Width = 1815
End
Begin VB.ListBox List1
Height = 3240
IntegralHeight = 0 'False
Left = 2220
Style = 1 'Checkbox
TabIndex = 1
Top = 120
Width = 4395
End
Begin VB.CommandButton cmdPopulate
Caption = "Populate the listbox"
Height = 375
Left = 120
TabIndex = 0
Top = 600
Width = 1815
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Number of items:"
Height = 195
Left = 180
TabIndex = 9
Top = 240
Width = 1185
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXFRAME = 32
Dim LBHS As CListBoxHScroll
Private Sub cmdAddItem_Click()
LBHS.AddItem "New item: " + String(Int(Rnd * 30) + 1, "W") + "!"
End Sub
Private Sub cmdChangeCap_Click()
LBHS.List(List1.ListCount - 1) = "New caption: " + String(Int(Rnd * 30) + 1, "W") + "!"
End Sub
Private Sub cmdClear_Click()
LBHS.Clear
End Sub
Private Sub cmdConnect_Click()
Dim i As Long
List1.Clear
For i = 1 To Val(txtItemCnt)
List1.AddItem "Item #" & i & ": " & String(Int(Rnd * 30) + 1, "W") & "!"
Next
LBHS.RefreshHScroll
End Sub
Private Sub cmdPopulate_Click()
Dim i As Long
LBHS.Clear
For i = 1 To Val(txtItemCnt)
LBHS.AddItem "Item #" & i & ": " & String(Int(Rnd * 30) + 1, "W") & "!"
Next
End Sub
Private Sub cmdRemoveHScr_Click()
Me.Width = List1.Left + _
LBHS.MinWidthNoHScroll * Screen.TwipsPerPixelX + _
2 * GetSystemMetrics(SM_CXFRAME) * Screen.TwipsPerPixelX + _
120
End Sub
Private Sub cmdRemoveLast_Click()
If List1.ListCount = 0 Then
MsgBox "Nothing to remove!", vbCritical
Else
LBHS.RemoveItem List1.ListCount - 1
End If
End Sub
Private Sub Form_Load()
With List1.Font
.Name = "Arial"
.Size = 12
.Italic = True
End With
Set LBHS = New CListBoxHScroll
LBHS.Attach List1
End Sub
Private Sub Form_Resize()
On Error Resume Next
List1.Move List1.Left, List1.Top, Me.ScaleWidth - List1.Left - 120, Me.ScaleHeight - List1.Top - 120
End Sub