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
' 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)
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.