Kolom breedtes in een ListBox automatisch aanpassen

Inhoud

Introductie
UserForm opzet
Hoe het aanpassen in zijn werk gaat
Module code
Conclusie

Introductie

Laatst had ik in een project een snelle methode nodig om de inhoud van een matrix aan de gebruiker te tonen. Ik wilde hiervoor geen werkblad gebruiken, maar koos voor een Userform. De matrix bevatte zoiets als:

Description

Before

After

Cell Errors

100

Corrupt Names

1000

Unused styles

232

Dus bedacht ik dat ik een listbox wilde gebruiken waarvan de kolombreedtes zich aan de gegevens zouden aanpassen. Dat bleek helemaal zo eenvoudig nog niet...

UserForm opzet

Ik heb een userform gemaakt dat er als volgt uitziet:

De userform inrichten

De userform bevat deze besturingselementen (met de belangrijkste eigenschappen):

Control naam

Type

AutoSize

Cancel

Caption

Default

TabIndex

Tag

WordWrap

Visible

lbxTable

ListBox

TRUE

cmbClose

CommandButton

FALSE

TRUE

lblTableTitle

Label

FALSE

Label1

TRUE

lblHidden

Label

TRUE

lblHidden

False

FALSE

Om dit formulier te kunnen gebruiken heb ik een aantal eigenschappen en methodes toegevoegd:

Eigenschap/methode

Omschrijving

Table (Variant)

Wordt gebruikt om de tabel door te geven die op het formulier moet worden getoond (type variant)

Title (string)

De titel die boven de listbox moet worden getoond

AutoColWidths (Boolean)

Instellen of de breedte van de kolommen zich automatisch aan de inhoud moet aanpassen

FormWidth and FormHeight (Double)

In gebruik door de CFormResizer klasse (zie het voorbeeld bestand) om het veranderen van de afmetingen van het formulier te verwerken

Initialise

Initializeert het formulier: leest de tabel, vult de listbox ermee en start de routine die de kolombreedtes aanpast.

Hieronder de VBA code van de het formulier:

'-------------------------------------------------------------
' Module    : ufShowTable
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 14-5-2008
' Purpose   : Code die het tonen van een tabel op dit formulier verwerkt
'-------------------------------------------------------------
Option Explicit

Private mvTable As Variant
Private mbAutoColWidths As Boolean

Private mdFormWidth As Double
Private mdFormHeight As Double

'Code voor form afmetingen aanpassing komt van:
'Stephen Bullen, www.oaltd.co.uk
'Rob Bovey, www.appspro.com

'Declareer een object voor de CFormResizer klasse voor het afhandelen van resize events
Dim mclsResizer As CFormResizer

'----------------------EVENT CODE ----------------------

Private Sub cmbClose_Click()
    Me.Hide
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Zodra de afmetingen van het formulier worden veranderd,
'           dan wordt het UserForm_Resize event
'           gestart. Deze runt vervolgens code in de Resizer klasse
'
' Date          Developer       Action
' ------------------------------------------------------
' 07 Oct 04     Stephen Bullen Initial version
'
Private Sub UserForm_Resize()
    If mclsResizer Is Nothing Then Exit Sub
    mclsResizer.FormResize
End Sub
'----------------------METHODS----------------------

Public Sub Initialise()
'---------------------------------------------------
' Procedure : Initialise
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 14-5-2008
' Purpose   : Initialiseert het formulier en laat de kolommen van de listbox aanpassen
'-------------------------------------------------------------------------
    Dim lRowCt As Long
    Dim lColCt As Long
    Dim lLengths() As Long

    On Error GoTo LocErr
    On Error GoTo LocErr
    ReDim lLengths(UBound(mvTable, 2))
    With lbxTable
        .Clear
        .ColumnCount = UBound(mvTable, 2) + 1
        For lRowCt = LBound(mvTable, 1) To UBound(mvTable, 1)
            For lColCt = LBound(mvTable, 2) To UBound(mvTable, 2)
                'Bewaar de langste tekst van elke kolom
                lLengths(lColCt) = Application.Max(4, lLengths(lColCt), Len(mvTable(lRowCt, lColCt)))
                If lColCt = LBound(mvTable, 2) Then
                    'Eerste element moet middels additem worden toegevoegd
                    .AddItem mvTable(lRowCt, lColCt)
                Else
                    .List(.ListCount - 1, lColCt - 1) = CStr(mvTable(lRowCt, lColCt))
                End If
            Next
        Next
    End With
    If AutoColWidths Then
        'Nu de kolombreedtes aanpassen
        SetWidths lLengths()
    End If

    'Form resizer klasse instantieren
    Set mclsResizer = New CFormResizer
    'Locatie voor form afmetingen doorgeven
    mclsResizer.RegistryKey = GSREGKEY
    'Doorgeven welk form de klasse moet verwerken
    Set mclsResizer.Form = Me

    'Tijdelijk het re-dimensioneren ven tbxTable uitzetten
    lbxTable.Tag = ""

    'Formulierafmetingen aanpassen aan listbox afmetingen
    'Het form_resize event verzorgt het juist positioneren van de overige elementen op het formulier
    Me.Width = lbxTable.Left + lbxTable.Width + 12
    Me.Height = lbxTable.Top + lbxTable.Height + 30 + cmbClose.Height

    'Re-dimensioneren van lbxTable weer inschakelen
    lbxTable.Tag = "WH"
TidyUp:
    On Error GoTo 0
    Exit Sub
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "Initialise", "Form ufShowTable")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Sub

Private Function SetWidths(lLengths() As Long)
'--------------------------------------------------
' Procedure : SetWidths
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 14-5-2008
' Purpose   : Stelt kolombreedtes in obv matrix met tekst lengtes
'--------------------------------------------------
    Dim lCt As Long
    Dim sWidths As String
    Dim dTotWidth As Double
    On Error GoTo LocErr
    For lCt = 1 To UBound(lLengths)
        With lblHidden
            'Gebruik een herhaling van de letter m omdat dit een brede letter is.
            'Gebruik een hoofdletter als het altijd moet passen
            .Caption = String(lLengths(lCt), "m")
        End With
        dTotWidth = dTotWidth + lblHidden.Width
        If Len(sWidths) = 0 Then
            sWidths = CStr(Int(lblHidden.Width) + 1)
        Else
            sWidths = sWidths & ";" & CStr(Int(lblHidden.Width) + 1)
        End If
    Next

    'Nu de kolombreedtes doorgeven
    lbxTable.ColumnWidths = sWidths

    'De dimensies van de listbox aanpassen;'
    'Wellicht goed om de constanten die ik hier heb gebruikt aan te passen.

    'Listbox zal altijd tenminste 200 breed zijn
    lbxTable.Width = Application.Min(Application.Max(200, dTotWidth + 12), lbxTable.Width)

    'Listbox zal altijd minstens 48 hoog zijn.
    lbxTable.Height = Application.Min(Application.Max((lbxTable.ListCount + 1) * 12, 48), lbxTable.Height)
TidyUp:
    On Error GoTo 0
    Exit Function
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "SetWidths", "Form ufShowTable")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Function

'----------------------PROPERTIES----------------------
Public Property Get Table() As Variant
    Table = mvTable
End Property

Public Property Let Table(ByVal vTable As Variant)
    mvTable = vTable
End Property

Public Property Let Title(ByVal sTitle As String)
    lblTableTitle.Caption = sTitle
End Property

Public Property Get AutoColWidths() As Boolean
    AutoColWidths = mbAutoColWidths
End Property

Public Property Let AutoColWidths(ByVal bAutoColWidths As Boolean)
    mbAutoColWidths = bAutoColWidths
End Property

Public Property Get FormWidth() As Double
    FormWidth = Me.Width
End Property

Public Property Let FormWidth(ByVal dFormWidth As Double)
    Me.Width = dFormWidth
End Property

Public Property Get FormHeight() As Double
    FormHeight = Me.Height
End Property

Public Property Let FormHeight(ByVal dFormHeight As Double)
    Me.Height = dFormHeight
End Property

De oplettende lezer zal het zijn opgevallen dat ik een aantal constanten als vaste waarden in de code heb opgenomen. Uiteraard is het beter om deze vaste waarden als eigenschappen in de code van het formulier op te nemen zodat ze door de aanroepende code kunnen worden ingesteld.

Hoe het aanpassen in zijn werk gaat

Verschillende mensen hebben een truc bedacht om de kolom breedtes te bepalen. Sommigen gebruiken constanten, waarmee het aantal te tonen karakters wordt vermenigvuldigd. Deze truc werkt echter niet betrouwbaar omdat de schermresolutie en het lettertype invloed hebben op het resultaat.
De beste methode die ik ken gebruikt een (verborgen) label op het formulier met de AutoSize eigenschap op waar. De label moet hetzelfde lettertype hebben als de listbox. Na veranderen van de tekst van de label, kan de breedte van de label worden afgelezen. Die breedte wordt vervolgens gebruikt als kolombreedte.

De Functie SetWidths op het codevenster van het userform verzorgt het instellen van de kolombreedtes. Een matrix van de grootste tekst lengtes per kolom wordt aan deze functie doorgegeven. Vervolgens wordt voor iedere kolom de "caption" van het label voorzien van dat aantal karakters. Ik gebruik daarbij steeds hetzelfde karakter en omdat het lettertype vaak proportioneel is gebruik ik een letter die traditioneel een grote breedte heeft, de m. Die letter bepaald dus in grote mate de resulterende breedte. Tenslotte worden de gevonden breedtes achter elkaar gezet gescheiden door een ; en aan de "ColumnWidths" eigenschap doorgegeven van de listbox.

Het is belangrijk de eigenschappen van het label juist in te stellen; WordWrap moet Onwaar zijn en AutoSize Waar.

Het eindresultaat ziet er zo uit:

Een userform met automatisch aangepaste tabel

Niet slecht!?

Module code

Om het formulier te kunnen gebruiken kan de volgende generieke functie worden gebruikt:

'-------------------------------------------------------------------------
' Module    : modShowTable
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 2-4-2008
' Purpose   : Toont een tabel op userform ufTable
'-------------------------------------------------------------------------
Option Explicit

Public Function ShowTable(vTable As Variant, sTableTitle As String, bAutoColWidths As Boolean) As Variant
'-------------------------------------------------------------------------
' Procedure : ShowTable
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 2-4-2008
' Purpose   : Toont vTable op userform ufShowTable, met een maximum breedte en hoogte.
'-------------------------------------------------------------------------
    Dim frmShowTable As ufShowTable
    On Error GoTo LocErr
    Set frmShowTable = New ufShowTable
    With frmShowTable
        .Table = vTable
        .Title = sTableTitle
        .Caption = GSAPPNAME
        .AutoColWidths = bAutoColWidths
        .Initialise
        .Show
    End With
TidyUp:
    On Error GoTo 0
    Exit Function
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "ShowTable", "Module modShowTable")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Function

U gebruikt deze functie als volgt:

Sub demo()
'-------------------------------------------------------------------------
' Procedure : demo
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 14-5-2008
' Purpose   : Toond usedrange op het formulier
'-------------------------------------------------------------------------
    ActiveSheet.UsedRange.Select
    ShowTable Selection.Value, "Test", True
End Sub

Conclusie

Zoals je hebt kunnen zien zijn er wat truukjes nodig om dit aan het werken te krijgen. De hebben een (verborgen) label gebruikt met AutoSize ingeschakeld en WordWrap uitgeschakeld. Vervolgens hebben we de breedte van dat label gebruikt om te bepalen hoeveel ruimte er nodig is om de tekst weer tegeven in de listbox.

Download het voorbeeld bestand

Vragen, suggesties en opmerkingen

Al het commentaar over deze pagina:

Commentaar van: Hans Schraven (23-1-2009 05:41:39) deeplink naar dit commentaar

Een soortgelijk resultaat verkrijg ik (als voorbeeld een listbox in een werkblad) door de ligaturen (I,j, en l) voor een half teken te rekenen.
In de code worden de gegevens van een blad in een matrix gezet, die daarna wordt ingelezen in de Listbox.

Sub kolombreedte()
sq = Range("A1").CurrentRegion
For j = 2 To Ubound(sq)
    For jj = 1 To Ubound(sq, 2)
     If Len(sq(j, jj)) - (Len(sq(j, jj)) - Len(Replace(Replace(Replace(sq(j, jj), "j", ""), "I", ""), "l", ""))) \ 2 > Len(sq(1, jj)) - (Len(sq(1, jj)) - Len(Replace(Replace(Replace(sq(1, jj), "j", ""), "I", ""), "l", ""))) \ 2 Then sq(1, jj) = sq(j, jj)
    Next
Next

For j = 1 To Ubound(sq, 2)
    c0 = c0 & Iif(c0 = "", "", ";") & (Len(sq(1, j)) - (Len(sq(1, j)) - Len(Replace(Replace(Replace(sq(1, j), "j", ""), "I", ""), "l", ""))) \ 2) * 6
    c1 = c1 + (Len(sq(1, j)) - (Len(sq(1, j)) - Len(Replace(Replace(Replace(sq(1, j), "j", ""), "I", ""), "l", ""))) \ 2) * 6
Next
sq = Range("A1").CurrentRegion
With ListBox1
    .ColumnCount = Ubound(sq, 2)
    .ColumnWidths = c0
    .Width = c1 + 6
    .list=sq
End With
End Sub

Heeft u vragen, suggesties of opmerkingen? Gebruik dan dit formulier.

Mocht uw vraag niet direct relevant zijn voor deze pagina, maar een algemene Excel vraag betreffen, dan adviseer ik om deze hier te stellen: excelexperts.nl/forum/index.php.