Kolom breedtes in een ListBox automatisch aanpassen
Inhoud
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:
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 bevat deze besturingselementen (met de belangrijkste eigenschappen):
Om dit formulier te kunnen gebruiken heb ik een aantal eigenschappen en methodes toegevoegd:
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:
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:
'-------------------------------------------------------------------------
' 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.
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.