Most Valuable Professional


View Jan Karel Pieterse's profile on LinkedIn subscribe to rss feed
Subscribe in a reader

Audit !!!

Probeer onze RefTreeAnalyser
de beste Excel formule auditing tool.

Speed up your file

FastExcel
The best tool to optimise your Excel model!
Home > Nederlandse site > Artikelen > Listbox Passend Maken > UserForm opzet
This page in English

Kolom breedtes in een ListBox automatisch aanpassen

UserForm opzet

Ik heb een userform gemaakt dat er als volgt uitziet:

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

Control naam Type AutoSize Cancel Caption Default TabIndex Tag WordWrap Visible
lbxTable ListBox         0 WH   TRUE
cmbClose CommandButton FALSE TRUE Close TRUE 1 TL   TRUE
lblTableTitle Label FALSE   Label1   2     TRUE
lblHidden Label TRUE   lblHidden   3   False FALSE

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

Eigenschap/methode Description
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 (www.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 (www.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 (www.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.


 


Vragen, suggesties en opmerkingen

Al het commentaar over deze pagina:


Comment by: Hans Schraven (1/23/2009 5:41:39 AM)

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.

<div class="vbacode">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</div>

 


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: www.eileenslounge.com.

Uw naam (verplicht veld):

Uw e-mail adres (Niet verplicht, dit adres wordt niet getoond)

Uw verzoek of commentaar:

Als u VBA code in uw commentaar plaatst, gebruik dan [VB] tags: [VB]Uw code[/VB].