Kolom breedtes in een ListBox automatisch aanpassen

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