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...
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
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:
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
