Add a Horizontal Scroll Bar to A List Box

Category:

Forms and Controls

Type:

Snippets

Difficulty:

Intermediate

Author:

Intelligent Solutions Inc.

Version Compatibility:

More information:

This routine adds a horizontal scroll bar only if necessary, based on the width of items in the list box. It will work even if the form's scale mode is non-standard (i.e., not set to vbTwips or vbPixels).

NOTE: I had trouble getting this to work under Windows NT. I don't know why. Works fine under 95/98 and has no adverse effects under NT.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Option Explicit Private Declare Function SendMessageByNum 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

Code:

Public Sub AddHorizontalScrollToLB(LB As Object)
'PURPOSE:  ADDS HORIZONTAL SCROLL BAR
'TO LIST BOX

'LOGIC:  ATTEMPTS TO DETERMINE
'IF SCROLL BOX IS NECESSARY, BASED
'ON WIDTH OF ITEMS IN LIST AND
'SCALE MODE OF THE CONTAINER

'IF THIS CANNOT BE DETERMINED,
'IT GOES AHEAD AND ADDS THE
'SCROLL BAR ANYWAY

'USAGE: JUST CALL
'AddHorizontalScrollToLB lstMyListBox

'WHERE lstMyListBox is the name of
'the list box to
'add the scroll bar to

Dim sngTextWidth As Single
Dim sngPixelWidth As Single
Dim lCount As Long, lCtr As Long

On Error GoTo ErrorHandler

'Determine if we can calculate
'pixelwidth.
sngPixelWidth = ControlWidthInPixels(LB)

If sngPixelWidth <> 0 Then

lCount = LB.ListCount
        For lCtr = 0 To lCount - 1
        
            'if using this function in a form rather
            'than a bas or class module,
            'change to me.textwidth
            'as there's no guarantee lb.parent
            'supports textwidth property
            
            sngTextWidth = LB.Parent.TextWidth(LB.List(lCtr) _
                  & " ")
              If sngTextWidth > LB.Width Then
                 SendMessageByNum LB.hwnd, _
                 LB_SETHORIZONTALEXTENT, sngPixelWidth + 1, 0
                 Exit For
              End If
        Next
Else
    SendMessageByNum LB.hwnd, LB_SETHORIZONTALEXTENT, _
    100000000, 0
End If

ErrorHandler:

Exit Sub
   
End Sub

Private Function CharactersPerPixelX() As Single
    CharactersPerPixelX = Format _
   (Screen.TwipsPerPixelX / 120, "######.####")
End Function

Private Function PointsPerPixelX() As Single
    PointsPerPixelX = InchesPerPixelX * 72
End Function

Private Function InchesPerPixelX() As Single
    Dim sngAns As Single
    sngAns = Screen.TwipsPerPixelX / 1440
    InchesPerPixelX = Format(sngAns, "#.#####")
End Function

Private Function CentimetersPerPixelX() As Single
     Dim sngAns As Single
     sngAns = Screen.TwipsPerPixelX / 567
     CentimetersPerPixelX = Format(sngAns, "#.#####")
End Function

Private Function MillimetersPerPixelX() As Single
    MillimetersPerPixelX = CentimetersPerPixelX * 10
End Function

Private Function ControlWidthInPixels(ctl As Object) As Single
Dim oTest As Object
Dim iScaleMode As Integer
Dim sngWidth As Single
Dim sngAns As Single

sngAns = 0
On Error Resume Next
    Set oTest = ctl.Parent
    iScaleMode = oTest.ScaleMode
    sngWidth = ctl.Width
    
If Err.Number <> 0 Then Exit Function

Err.Clear
On Error GoTo 0

Select Case iScaleMode
    Case vbTwips
        sngAns = sngWidth / Screen.TwipsPerPixelX
    Case vbInches
        sngAns = sngWidth / InchesPerPixelX
    Case vbCentimeters
        sngAns = sngWidth / CentimetersPerPixelX
    Case vbMillimeters
        sngAns = sngWidth / MillimetersPerPixelX
    Case vbPoints
        sngAns = sngWidth / PointsPerPixelX
    Case vbCharacters
        sngAns = sngWidth / CharactersPerPixelX
    Case vbPixels
        sngAns = sngWidth
        
End Select

'format ans to 4 decimal places
    If sngAns <> 0 Then
           ControlWidthInPixels = Format _
              (sngAns, "#########.####")
    End If

End Function