ABOUT Visual Basic - das Webmagazin: Rollkommando (Klasse)

ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE

(-hg)

Ein horizontaler Rollbalken gehört leider nicht zur Standard-Ausstattung einer ListBox, wenn die Elemente aus dem sichtbaren Bereich der ListBox hinausragen. An sich ist das eine einfache Angelegenheit: Sie brauchen der ListBox nur über die API-Funktion SendMessage die API-Nachricht LB_SETHORIZONTALEXTENT zukommen zu lassen und ihr dabei die "virtuelle" Breite (ScrollWidth) in Pixels anzugeben, und der horizontale Rollbalken erscheint. Wenn Sie als ScrollWidth den Wert 0 angeben, verschwindet der Rollbalken wieder.

Private Declare Function SendMessage Lib "user32" _
 Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
 ByVal wParam As Long, lParam As Long) As Long

SendMessage _
 ListBox.hwnd, LB_SETHORIZONTALEXTENT, ScrollWidth, ByVal 0&

Die Frage ist allerdings, wie Sie zunächst die benötigte virtuelle Breite exakt ermitteln können. Denn die Anzeige eines horizontalen Rollbalkens ist ja nicht notwendig, wenn die keines der Elemente in der ListBox breiter als der sichtbare Bereich ist. Sie können dazu alle Elemente der ListBox durchlaufen und dabei die größte Breite ermitteln. Ist diese dann größer als die Breite des sichtbaren Bereichs, können Sie die virtuelle Breite auf diesen Wert setzen. Den sichtbaren Bereich der ListBox erhalten Sie über die API-Funktion GetClientRect. Diese liefert Ihnen immer die Größe des tatsächlichen sichtbaren Bereichs der ListBox. Dabei werden sowohl ein gerade angezeigter vertikaler Rollbalken als auch die Stärke des Rahmens (dreidimensional oder flach) berücksichtigt.

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetClientRect Lib "user32" _
 (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SendMessage Lib "user32" _
 Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
 ByVal wParam As Long, lParam As Long) As Long

Dim nParent As Object
Dim nFont As StdFont
Dim l As Long
Dim nTextWidth As Single
Dim nMaxWidth As Single
Dim nRect As RECT

Const lBorderWidth = 4

With ListBox
  If .ListCount Then
    With.Container
      Set nFont = .Font
      Set .Font = pListBox.Font
      For l = 0 To pListBox.ListCount - 1
        nTextWidth = .TextWidth(pListBox.List(l))
        If nTextWidth > nMaxWidth Then
          nMaxWidth = nTextWidth
        End If
      Next 'l
      Set .Font = nFont
    End With
    GetClientRect .hWnd, nRect
    If nMaxWidth + lBorderWidth > nRect.Right Then 
      nMaxWidth = nMaxWidth + lBorderWidth
    Else
      nMaxWidth = 0
    End If
  Else
    nMaxWidth = 0
  End If
  SendMessage.hwnd, LB_SETHORIZONTALEXTENT, nMaxWidth, ByVal 0&
End With

Dieses Procedere müssen Sie nun jedes Mal ausführen, wenn ein Element der ListBox hinzugefügt wird, ein Element aus ihr entfernt wird, oder wenn sich die Länge eines der Elemente ändert. Natürlich können Sie das auch in eine separate Prozedur packen und diese dann nach jeder Änderung der ListBox-Elemente aufrufen. Allerdings hätte diese Prozedur einen schwerwiegenden Nachteil: Je mehr Elemente die ListBox enthält, um so länger dauert jedoch die Ermittlung der benötigten virtuellen Breite.

Der Gedanke, die zuletzt ermittelte benötigte virtuelle Breite in einer Variablen zu speichern und nur noch mit der Länge eines hinzugefügten Elements zu vergleichen und gegebenenfalls heraufzusetzen, ist naheliegend. Beim Entfernen eines Elements müssen Sie hingegen prüfen, ob das zu entfernende Element kürzer ist, als der zuletzt ermittelte Wert. Ist das der Fall, erübrigt sich eine Änderung der virtuellen Breite. Entspricht seine Länge der virtuellen Breite, bleibt Ihnen kaum etwas anderes übrig, als die komplette Ermittlung für sämtliche verbleibenden Elemente erneut durchzuführen. Bei der Änderung eines ListBox-Elements müssen Sie sogar beide Fälle prüfen. Und nach einem kompletten Leeren der ListBox müssen Sie die virtuelle Breite zumindest wieder auf 0 setzen, um den horizontalen Rollbalken verschwinden zu lassen.

Alle diese dafür zusätzlich benötigten Prozeduren und Funktionen können Sie zwar in ein Standard-Modul stecken und dazu jeweils beim Aufruf eine Referenz auf die betreffende ListBox übergeben. Doch je mehr ListBoxen Sie verwenden und mit der horizontalen Rollfähigkeit beglücken, um so mehr Variablen zur Speicherung des jeweiligen Maximal-Wertes müssen Sie verwalten - womöglich sind diese Variablen dann über Ihre ganze Anwendung verstreut. Sie könnten den zuletzt ermittelten Wert zwar in der Tag-Eigenschaft der ListBox ablegen, doch wäre diese Eigenschaft dann nicht mehr anderweitig nutzbar.

Sobald jedoch allgemein nutzbare Prozeduren bzw. Funktionen mit objektspezifischen Variablen (und bei ListBoxen handelt es sich ja schließlich um Objekte) zusammenkommen, bietet es sich an, anstelle eines Standard-Moduls eine Klasse anzulegen. Je einer Instanz dieser Klasse kann genau eine ListBox zugewiesen werden und jede Instanz kann den Maximal-Wert individuell als private Variable verwalten. Darüber hinaus können Sie die Automatik der Ermittlung des Maximal-Werts über eine zusätzliche Eigenschaft (AutoHScroll) ein- oder ausschalten, oder auch zu einer festen, von den Elementen unabhängigen virtuellen Breite (ScrollWidth) umschalten. Und statt der ursprünglichen AddItem-, RemoveItem- und Clear-Methode der ListBox rufen Sie nun Methoden der Klasse auf, die die notwendigen Prüfungen vornimmt und dabei den beabsichtigten Aufruf an die ListBox weiterreicht. Dasselbe gilt für die List-Eigenschaft zur Änderung eines ListBox-Elements.

Sie brauchen eigentlich auch nur diese Methoden und diese Eigenschaft zu übertragen. Doch wenn Sie dazu noch die wichtigsten weiteren Methoden und Eigenschaften einer ListBox übertragen, können Sie mit einer Instanz dieser Klasse fast wie mit einer originalen ListBox umgehen. Und sollten Sie doch einmal den Zugriff auf eine der weiteren und nicht übertragenen Methoden oder Eigenschaften benötigen, kommen Sie über die Eigenschaft ListBox der Klasse direkt an die betreffende ListBox heran. Außerdem können Sie sogar noch ein paar kleine Verbesserungen einbringen, wie etwa eine optionale ListIndex-Angabe etwa bei RemoveItem oder List usw. - wird die explizite ListIndex-Angabe hier weggelassen, wird automatisch der aktuelle ListIndex der TextBox verwendet.

Die Verwendung der Klasse ist denkbar einfach. Sie legen eine Instanz an, etwa im Form_Load-Ereignis des Forms, auf dem die ListBox platziert ist und rufen die Init-Methode der Klasse auf, der Sie die Referenz auf die betreffende ListBox übergeben:

Private mListBoxHS As ListBoxHScroll

Private Sub Form_Load()
  Set mListBoxHS = New ListBoxHScroll
  mListBoxHS.Init List1
End Sub

Beim Aufruf der Init-Methode können Sie eventuell gleich die AutoHScroll-Eigenschaft abschalten und auf Wunsch eine feste virtuelle Breite übergeben.

Das Hinzufügen oder Entfernen von Elementen erfolgt wie gewohnt, nun aber über die Instanz der Klasse:

mListBoxHS.AddItem Item[, Index]

und

mListBoxHS.RemoveItem [Index]

Wie bereits erwähnt ist die Index-Angabe bei RemoveItem nunmehr optional.

Hier sehen Sie nun den kompletten Code der Klasse ListBoxHScroll:

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetClientRect Lib "user32" _
 (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SendMessage Lib "user32" _
 Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
 ByVal wParam As Long, lParam As Long) As Long
  
Private mScrollWidth As Long

Public Enum ListBoxHScrollErrorConstants
  lbhsErrNoListBoxAttached = vbObjectError + 10000
  lbhsErrInvalidScrollWidthValue = vbObjectError + 10001
  lbhsErrInvalidRecalcParam = vbObjectError + 10002
  lbhsErrNoIndexToRemove = vbObjectError + 10003
  lbhsErrInvlidListIndex = vbObjectError + 10004
End Enum

Public Enum ListBoxHScrollRecalcModeConstants
  lbhsNoRecalc
  lbhsRecalcMax
  lbhsRecalcMaxSet
  lbhsRecalcAll
  lbhsRecalcAllSet
End Enum

Private pAutoHScroll As Boolean
Private pListBox As ListBox
Private pScrollWidth As Long

Public Property Get AutoHScroll() As Boolean
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.AutoHScroll [Get]"
  Else
    AutoHScroll = pAutoHScroll
  End If
End Property

Public Property Let AutoHScroll(ByVal New_AutoHScroll As Boolean)
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.AutoHScroll [Let]"
  Else
    If pAutoHScroll <> New_AutoHScroll Then
      pAutoHScroll = New_AutoHScroll
      If pAutoHScroll Then
        zSetScrollWidthAllItems
      Else
        zSetScrollWidth pScrollWidth
      End If
    End If
  End If
End Property

Public Property Get ItemData(Optional ByVal Index As Long = -1) _
 As Long

  Dim nIndex As Long
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.ItemData [Get]"
  Else
    With pListBox
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      Select Case nIndex
        Case 0 To .ListCount - 1
          ItemData = .ItemData(nIndex)
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.ItemData [Get]"
      End Select
    End With
  End If
End Property

Public Property Let ItemData(Optional ByVal Index As Long = -1, _
 New_ItemData As Long)

  Dim nIndex As Long
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.ItemData [Let]"
  Else
    With pListBox
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      Select Case nIndex
        Case 0 To .ListCount - 1
          .ItemData(nIndex) = New_ItemData
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.ItemData [Let]"
      End Select
    End With
  End If
End Property

Public Property Get ListBox() As ListBox
  Set ListBox = pListBox
End Property

Public Property Get List(Optional ByVal Index As Long = -1, _
 Optional ByVal Recalc As ListBoxHScrollRecalcModeConstants = _
 lbhsRecalcMaxSet) As String

  Dim nIndex As Long
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.ListItem [Get]"
  Else
    With pListBox
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      Select Case nIndex
        Case 0 To .ListCount - 1
          List = .List(nIndex)
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.ListItem [Get]"
      End Select
    End With
  End If
End Property

Public Property Let List(Optional ByVal Index As Long = -1, _
 Optional ByVal Recalc As ListBoxHScrollRecalcModeConstants = _
 lbhsRecalcMaxSet, New_Item As String)

  Dim nIndex As Long
  Dim nOldItem As String
  Dim nFont As StdFont
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.ListItem [Let]"
  Else
    Select Case Recalc
      Case lbhsNoRecalc To lbhsRecalcAllSet
      Case Else
        Err.Raise lbhsErrInvalidRecalcParam, _
         "ListBoxHScroll.ListItem [Let]"
    End Select
    With pListBox
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      Select Case nIndex
        Case 0 To .ListCount - 1
          nOldItem = .List(nIndex)
          If nOldItem <> New_Item Then
            .List(nIndex) = New_Item
            If pAutoHScroll Then
              Select Case Recalc
                Case lbhsNoRecalc
                Case lbhsRecalcMax
                  With .Container
                    Set nFont = .Font
                    Set .Font = pListBox.Font
                    If .ScaleX(.TextWidth(nOldItem), _
                     .ScaleMode, vbPixels) = mScrollWidth Then
                      zSetScrollWidthAllItems False
                    Else
                      zSetScrollWidth _
                       zCalcMaxItemWidth(New_Item), False
                    End If
                    Set .Font = nFont
                  End With
                Case lbhsRecalcMaxSet
                  With .Container
                    Set nFont = .Font
                    Set .Font = pListBox.Font
                    If .ScaleX(.TextWidth(nOldItem), _
                     .ScaleMode, vbPixels) = mScrollWidth Then
                      zSetScrollWidthAllItems
                    Else
                      zSetScrollWidth zCalcMaxItemWidth(New_Item)
                    End If
                    Set .Font = nFont
                  End With
                Case lbhsRecalcAll
                  zSetScrollWidthAllItems False
                Case lbhsRecalcAllSet
                  zSetScrollWidthAllItems
              End Select
            End If
          End If
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.ListItem [Let]"
      End Select
    End With
  End If
End Property

Public Property Get ListCount() As Long
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.ListCount [Get]"
  Else
    ListCount = pListBox.ListCount
  End If
End Property

Public Property Get NewIndex() As Long
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.NewIndex [Get]"
  Else
    NewIndex = pListBox.NewIndex
  End If
End Property

Public Property Get ScrollWidth() As Single
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.ScrollWidth [Get]"
  Else
    With pListBox.Container
      ScrollWidth = .ScaleX(pScrollWidth, vbPixels, .ScaleMode)
    End With
  End If
End Property

Public Property Let ScrollWidth(ByVal New_ScrollWidth As Single)
  Select Case New_ScrollWidth
    Case pScrollWidth
    Case Is >= 0
      If pListBox Is Nothing Then
        Err.Raise lbhsErrNoListBoxAttached, _
         "ListBoxHScroll.ScrollWidth [Let]"
      Else
        With pListBox.Container
          pScrollWidth = _
           .ScaleX(New_ScrollWidth, .ScaleMode, vbPixels)
        End With
        If Not pAutoHScroll Then
          zSetScrollWidth pScrollWidth
        End If
      End If
    Case Else
      Err.Raise 380
  End Select
End Property

Public Property Get SelCount() As Long
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.SelCount [Get]"
  Else
    SelCount = pListBox.SelCount
  End If
End Property

Public Property Get Selected(Optional ByVal Index As Long = -1) _
 As Boolean

  Dim nIndex As Long
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.Selected [Get]"
  Else
    With pListBox
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      Select Case nIndex
        Case 0 To .ListCount - 1
          Selected = .Selected(nIndex)
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.Selected [Get]"
      End Select
    End With
  End If
End Property

Public Property Let Selected(Optional ByVal Index As Long = -1, _
 New_Selected As Boolean)

  Dim nIndex As Long
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.Selected [Let]"
  Else
    With pListBox
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      Select Case nIndex
        Case 0 To .ListCount - 1
          .Selected(nIndex) = New_Selected
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.Selected [Let]"
      End Select
    End With
  End If
End Property

Public Property Get Text() As String
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.Text [Get]"
  Else
    Text = pListBox.Text
  End If
End Property

Public Property Get TopIndex() As Long
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.TopIndex [Get]"
  Else
    TopIndex = pListBox.TopIndex
  End If
End Property

Public Property Let TopIndex(ByVal New_TopIndex As Long)
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.TopIndex [Let]"
  Else
    With pListBox
      Select Case New_TopIndex
        Case 0 To .ListCount - 1
          .TopIndex = New_TopIndex
        Case Else
          Err.Raise lbhsErrInvlidListIndex, _
           "ListBoxHScroll.TopIndex [Let]"
      End Select
    End With
  End If
End Property

Public Sub AddItem(Item As String, _
 Optional ByVal Index As Long = -1, _
 Optional ByVal Recalc As ListBoxHScrollRecalcModeConstants = _
 lbhsRecalcMaxSet)

  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.AddItem"
  Else
    Select Case Recalc
      Case lbhsNoRecalc To lbhsRecalcAllSet
      Case Else
        Err.Raise lbhsErrInvalidRecalcParam, _
         "ListBoxHScroll.AddItem"
    End Select
    If Index > -1 Then
      pListBox.AddItem Item, Index
    Else
      pListBox.AddItem Item
    End If
    If pAutoHScroll Then
      Select Case Recalc
        Case lbhsNoRecalc
        Case lbhsRecalcMax
          zSetScrollWidth zCalcMaxItemWidth(Item), False
        Case lbhsRecalcMaxSet
          zSetScrollWidth zCalcMaxItemWidth(Item)
        Case lbhsRecalcAll
          zSetScrollWidthAllItems False
        Case lbhsRecalcAllSet
          zSetScrollWidthAllItems
      End Select
    End If
  End If
End Sub

Public Sub Clear( _
 Optional ByVal Recalc As ListBoxHScrollRecalcModeConstants)

  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, "ListBoxHScroll.Clear"
  Else
    Select Case Recalc
      Case lbhsNoRecalc
      Case lbhsRecalcMax To lbhsRecalcAllSet
        zSetScrollWidth
      Case Else
        Err.Raise lbhsErrInvalidRecalcParam, _
         "ListBoxHScroll.Clear"
    End Select
    pListBox.Clear
  End If
End Sub

Public Sub Refresh( _
 Optional ByVal RefreshMaxScrollWidth As Boolean)

  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, "ListBoxHScroll.Init"
  Else
    If RefreshMaxScrollWidth Then
      zSetScrollWidth mScrollWidth
    Else
      If pAutoHScroll Then
        zSetScrollWidthAllItems
      Else
        zSetScrollWidth pScrollWidth
      End If
    End If
  End If
  pListBox.Refresh
End Sub

Public Sub RemoveItem(Optional ByVal Index As Long = -1, _
 Optional ByVal Recalc As ListBoxHScrollRecalcModeConstants = _
 lbhsRecalcMaxSet)

  Dim nIndex As Long
  Dim nItem As String
  Dim nFont As StdFont
  
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.RemoveItem"
  Else
    With pListBox
      If pAutoHScroll Then
        Select Case Recalc
          Case lbhsNoRecalc To lbhsRecalcAllSet
          Case Else
            Err.Raise lbhsErrInvalidRecalcParam, _
             "ListBoxHScroll.RemoveItem"
        End Select
      End If
      If Index < 0 Then
        nIndex = .ListIndex
      Else
        nIndex = Index
      End If
      If nIndex > -1 Then
        If pAutoHScroll Then
          nItem = .List(nIndex)
          .RemoveItem nIndex
          Select Case Recalc
            Case lbhsNoRecalc
            Case lbhsRecalcMax
              If mScrollWidth Then
                With pListBox.Parent
                  Set nFont = .Font
                  Set .Font = pListBox.Font
                  If .ScaleX(.TextWidth(nItem), _
                   .ScaleMode, vbPixels) = mScrollWidth Then
                    zSetScrollWidthAllItems False
                  End If
                  Set .Font = nFont
                End With
              End If
            Case lbhsRecalcMaxSet
              With pListBox.Parent
                If mScrollWidth Then
                  Set nFont = .Font
                  Set .Font = pListBox.Font
                  If .ScaleX(.TextWidth(nItem), _
                   .ScaleMode, vbPixels) = mScrollWidth Then
                    zSetScrollWidthAllItems
                  End If
                  Set .Font = nFont
                End If
              End With
            Case lbhsRecalcAll
              zSetScrollWidthAllItems False
            Case lbhsRecalcAllSet
              zSetScrollWidthAllItems
          End Select
        Else
          .RemoveItem nIndex
        End If
      Else
        Err.Raise lbhsErrNoIndexToRemove, _
         "ListBoxHScroll.RemoveItem"
      End If
    End With
  End If
End Sub

Public Sub SetFocus()
  If pListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, _
     "ListBoxHScroll.SetFocus"
  Else
    pListBox.SetFocus
  End If
End Sub

Public Sub Init(ListBox As ListBox, _
 Optional ByVal AutoHScroll As Boolean, _
 Optional ByVal ScrollWidth As Single)

  If ListBox Is Nothing Then
    Err.Raise lbhsErrNoListBoxAttached, "ListBoxHScroll.Init"
  Else
    If ScrollWidth < 0 Then
      Err.Raise lbhsErrInvalidScrollWidthValue, _
       "ListBoxHScroll.Init"
    Else
      Set pListBox = ListBox
      pAutoHScroll = AutoHScroll
      With pListBox.Container
        pScrollWidth = _
         .ScaleX(ScrollWidth, .ScaleMode, vbPixels)
      End With
      Me.Refresh
    End If
  End If
End Sub

Private Sub Class_Initialize()
  pAutoHScroll = True
End Sub

Private Sub Class_Terminate()
  Set pListBox = Nothing
End Sub

Private Sub zSetScrollWidthAllItems( _
 Optional ByVal iSetScrollWidth = True)

  Dim nParent As Object
  Dim nFont As StdFont
  Dim l As Long
  Dim nTextWidth As Single
  Dim nScrollWidth As Single
  
  If pListBox.ListCount Then
    With pListBox.Container
      Set nFont = .Font
      Set .Font = pListBox.Font
      For l = 0 To pListBox.ListCount - 1
        nTextWidth = .TextWidth(pListBox.List(l))
        If nTextWidth > nScrollWidth Then
          nScrollWidth = nTextWidth
        End If
      Next 'l
      zSetScrollWidth .ScaleX(nScrollWidth, .ScaleMode, _
       vbPixels), iSetScrollWidth
      Set .Font = nFont
    End With
  Else
    zSetScrollWidth 0, iSetScrollWidth
  End If
End Sub

Private Sub zSetScrollWidth( _
 Optional ByVal iScrollWidth As Single, _
 Optional ByVal iSetScrollWidth = True)

  Dim nRect As RECT
  Dim nScrollWidth As Long
  
  Const LB_SETHORIZONTALEXTENT = &H194
  Const lBorderWidth = 4
  
  Select Case iScrollWidth
    Case mScrollWidth
    Case Else
      With pListBox
        If iScrollWidth > 0 Then
          GetClientRect .hwnd, nRect
          If iScrollWidth + lBorderWidth > _
           nRect.Right Then
            nScrollWidth = iScrollWidth
          End If
        Else
          nScrollWidth = 0
        End If
        If nScrollWidth <> mScrollWidth Then
          mScrollWidth = nScrollWidth
          If iSetScrollWidth Then
            SendMessage .hwnd, LB_SETHORIZONTALEXTENT, _
             mScrollWidth + lBorderWidth, ByVal 0&
          End If
        End If
      End With
  End Select
End Sub

Private Function zCalcMaxItemWidth(iItem As String) As Single
  Dim nTextWidth As Single
  Dim nFont As StdFont

  With pListBox.Parent
    Set nFont = .Font
    Set .Font = pListBox.Font
    nTextWidth = _
     .ScaleX(.TextWidth(iItem), .ScaleMode, vbPixels)
    If nTextWidth > mScrollWidth Then
      zCalcMaxItemWidth = nTextWidth
    Else
      zCalcMaxItemWidth = mScrollWidth
    End If
    Set .Font = nFont
  End With
End Function

Die Klasse ListBoxHScroll (ListBoxHScroll.zip - ca. 19 KB)

					Copyright © 1999 - 2023 Harald M. Genauck, ip-pro gmbh / Impressum