======================
ListBoxHScroll Class 
======================
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




======================
Test form with ListBox
======================
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
