Just playing around with an idea of making list boxes and combo boxes have the column width autoresize based on the content of those same column and thought I’d share a first run at the concept.
List box/Combo box Auto-resizing Columns Code
The concept is straight forward, run through the contents of the control and identify the longest entry in each column, then calculate the require width to display that ‘longest’ entry and resize the column to match (+ a little buffer).
Main Sub
Enum ResizeTechnique
ExplicitSizing = 1 'Based on required text size -> may go beyond the width of the listbox requiring scrollbars
SizeToFit = 2 'Percentage Ratio -> force everything within the width of the listbox, content may be cut-off
End Enum
'---------------------------------------------------------------------------------------
' Procedure : Control_AutoSizeColumns
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Auto-resize list box/combo box column to match the longest entry
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
' Dependencies: String_Dimensions() & Enum ResizeTechnique
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' oCtrl : List box or Combo box control to resize to columns of
' lResizeTechnique : Resizing technique to apply
'
' Usage:
' ~~~~~~
' Control_AutoSizeColumns(Me.List0, ExplicitSizing)
'
'' Control_AutoSizeColumns(Me.Combo0, SizeToFit)
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2024-03-29 Initial Release
'---------------------------------------------------------------------------------------
Sub Control_AutoSizeColumns(oCtrl As Access.Control, _
Optional lResizeTechnique As ResizeTechnique = ExplicitSizing)
On Error GoTo Error_Handler
Dim lNoCols As Integer
Dim lNoRows As Long
Dim lColCounter As Long
Dim lRowCounter As Long
Dim aMaxColEntries() As String
Dim lHeight As Long
Dim lWidth As Long
Dim sColWidths As String
Dim aCtrlColWidths() As String
Dim lTotalReqWidth As Long
Const lBuffer = 150
lNoCols = oCtrl.ColumnCount
lNoRows = oCtrl.ListCount
' Determine the biggest entries per column
' ****************************************************************************************
'Size the array
ReDim aMaxColEntries(lNoCols - 1, 0)
'Initialize the array with the 1st row values
For lColCounter = 0 To lNoCols - 1
aMaxColEntries(lColCounter, 0) = oCtrl.Column(lColCounter, lRowCounter)
Next lColCounter
'Process all the other rows
For lRowCounter = 1 To lNoRows - 1
For lColCounter = 0 To lNoCols - 1
'Debug.Print , Me.List0.Column(lColCounter, lRowCounter)
If Len(oCtrl.Column(lColCounter, lRowCounter)) > Len(aMaxColEntries(lColCounter, 0)) Then
aMaxColEntries(lColCounter, 0) = oCtrl.Column(lColCounter, lRowCounter)
End If
Next lColCounter
Next lRowCounter
aCtrlColWidths = Split(oCtrl.ColumnWidths, ";")
If UBound(aCtrlColWidths) <> lNoCols - 1 Then
Debug.Print "Number of data columns doesn't match number of column defined in the Column Widths"
Exit Sub
End If
If lResizeTechnique = ExplicitSizing Then
' Determine the require width to fit
' ****************************************************************************************
For lColCounter = 0 To lNoCols - 1
'Debug.Print lColCounter, aMaxColEntries(lColCounter, 0)
With oCtrl
If CLng(aCtrlColWidths(lColCounter)) = 0 Then
sColWidths = sColWidths & 0 & ";"
Else
Call String_Dimensions(lHeight, lWidth, aMaxColEntries(lColCounter, 0), .FontName, .FontSize, .FontWeight, .FontItalic, .FontUnderline, 0, 0)
sColWidths = sColWidths & lWidth + lBuffer & ";"
lTotalReqWidth = lTotalReqWidth + lWidth + lBuffer
End If
End With
'Debug.Print lWidth
Next lColCounter
Else
'Calculate Total Width Required
For lColCounter = 0 To lNoCols - 1
If CLng(aCtrlColWidths(lColCounter)) = 0 Then
lTotalReqWidth = lTotalReqWidth + 0
Else
With oCtrl
Call String_Dimensions(lHeight, lWidth, aMaxColEntries(lColCounter, 0), .FontName, .FontSize, .FontWeight, .FontItalic, .FontUnderline, 0, 0)
End With
lTotalReqWidth = lTotalReqWidth + lWidth + lBuffer
End If
Next lColCounter
For lColCounter = 0 To lNoCols - 1
If CLng(aCtrlColWidths(lColCounter)) = 0 Then
sColWidths = sColWidths & 0 & ";"
Else
With oCtrl
Call String_Dimensions(lHeight, lWidth, aMaxColEntries(lColCounter, 0), .FontName, .FontSize, .FontWeight, .FontItalic, .FontUnderline, 0, 0)
End With
sColWidths = sColWidths & (oCtrl.Width / lTotalReqWidth) * (lWidth + lBuffer) & ";"
End If
Next lColCounter
End If
oCtrl.ColumnWidths = sColWidths
If oCtrl.ControlType = acComboBox And lResizeTechnique = ExplicitSizing Then
oCtrl.ListWidth = lTotalReqWidth
Else
oCtrl.ListWidth = oCtrl.Width
End If
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Control_AutoSizeColumns" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
Helper Procedure(s)
The above requires a WizHook helper function to be able to calculate the height/width of the string of text based on the specified font.
'---------------------------------------------------------------------------------------
' Procedure : String_Dimensions
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Retrieve the height/width of a string based on a specified font
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
' References:
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' lHeight : Variable to return the height with
' lWidth : Variable to return the width with
' sCaption : String to calculate the dimension of
' sFontName : Name of the font to calculate the dimension of
' lSize : Size of the font to calculate the dimension of
' lWeight : Weight of the font to calculate the dimension of
' bItalic : Is the font italicied
' bUnderline : Is the font underlined
' lCch : Average character width - leave 0
' lMaxWidthCch : How many character to consider the max char width - leave 0
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2024-03-29 Initial Release
'---------------------------------------------------------------------------------------
Public Function String_Dimensions(ByRef lHeight As Long, _
ByRef lWidth As Long, _
ByVal sCaption As String, _
ByVal sFontName As String, _
ByVal lSize As Long, _
Optional ByVal lWeight As Long = 400, _
Optional bItalic As Boolean = False, _
Optional bUnderline As Boolean = False, _
Optional lCch As Long = 0, _
Optional lMaxWidthCch As Long = 0) As Double
On Error GoTo Error_Handler
Dim dx As Long
Dim dy As Long
Const lBuffer = 15
WizHook.Key = 51488399
WizHook.TwipsFromFont sFontName, lSize, lWeight, bItalic, bUnderline, lCch, sCaption, lMaxWidthCch, dx, dy
lHeight = dy + lBuffer
lWidth = dx + lBuffer
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: String_Dimensions" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Implementation Of The Code
Nothing could be easier! With the above, we can now auto-resize any list box/combo box with a single line of code.
Call Control_AutoSizeColumns(Me.List2)
Call Control_AutoSizeColumns(Me.List2, SizeToFit)
Beware
This code is a proof of concept, just playing around with an idea I had in my head, and has not been thoroughly tested.
For short lists of choices this will work perfectly, but for long lists it might be best to limit the iteration to try and limit the performance impact it may make on the loading of your form/report.
Also, in the above, I’ve hard-coded the list separator as ‘;’, but depending on your regional settings this may not be true and thus would need to be adjusted accordingly, or better yet should be implemented using the concepts elaborated in my internationalization article:
Special Characters and Internationalization of an Application
The Problem If ever you get into developing applications, especially Access databases, that are deployed on various countries and/or where users change the default Regional settings you will quickly ask yourself why, oh why, did Microsoft make things so complex. For example creating a value list through VBA, some languages use a comma (,), others the semicolon (;) and so on, and so on it goes for decimal separators, date separators, … So hard coding the separator is a no-no unless you are in a very controlled environment! Let’s look at a simple example, such as getting a listing of…
%100 String Width Verification
If you truly want to validate things, instead of using the Len() to find the longest string entered, one would need to calculate the string width for every single value. That said, I chose not to do this above as this can have performance implications and I’ve found, generally speaking, the Len() approach to be acceptable. That said, below would be the 100% accurate approach if it should interest you.
'---------------------------------------------------------------------------------------
' Procedure : Control_AutoSizeColumns
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Auto-resize list box/combo box column to match the longest entry
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
' Dependencies: String_Dimensions() & Enum ResizeTechnique
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' oCtrl : List box or Combo box control to resize to columns of
' lResizeTechnique : Resizing technique to apply
'
' Usage:
' ~~~~~~
' Control_AutoSizeColumns(Me.List0, ExplicitSizing)
'
'' Control_AutoSizeColumns(Me.Combo0, SizeToFit)
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2024-03-29 Initial Release
'---------------------------------------------------------------------------------------
Sub Control_AutoSizeColumns(oCtrl As Access.Control, _
Optional lResizeTechnique As ResizeTechnique = ExplicitSizing)
On Error GoTo Error_Handler
Dim lNoCols As Integer
Dim lNoRows As Long
Dim lColCounter As Long
Dim lRowCounter As Long
Dim aMaxColEntries() As String
Dim lHeight As Long
Dim lWidth As Long
Dim sColWidths As String
Dim aCtrlColWidths() As String
Dim lTotalReqWidth As Long
Const lBuffer = 150
lNoCols = oCtrl.ColumnCount
lNoRows = oCtrl.ListCount
' Determine the biggest entries per column
' ****************************************************************************************
'Size the array
ReDim aMaxColEntries(lNoCols - 1, 0)
'Initialize the array with the 1st row values
For lColCounter = 0 To lNoCols - 1
With oCtrl
Call String_Dimensions(lHeight, lWidth, oCtrl.Column(lColCounter, 0), .FontName, .FontSize, .FontWeight, .FontItalic, .FontUnderline, 0, 0)
End With
aMaxColEntries(lColCounter, 0) = lWidth
Next lColCounter
'Process all the other rows
For lRowCounter = 1 To lNoRows - 1
For lColCounter = 0 To lNoCols - 1
With oCtrl
Call String_Dimensions(lHeight, lWidth, oCtrl.Column(lColCounter, lRowCounter), .FontName, .FontSize, .FontWeight, .FontItalic, .FontUnderline, 0, 0)
End With
If lWidth > aMaxColEntries(lColCounter, 0) Then
aMaxColEntries(lColCounter, 0) = lWidth
'Debug.Print lColCounter, lWidth
End If
Next lColCounter
Next lRowCounter
aCtrlColWidths = Split(oCtrl.ColumnWidths, ";")
If UBound(aCtrlColWidths) <> lNoCols - 1 Then
Debug.Print "Number of data columns doesn't match number of column defined in the Column Widths"
Exit Sub
End If
If lResizeTechnique = ExplicitSizing Then
' Determine the require width to fit
' ****************************************************************************************
For lColCounter = 0 To lNoCols - 1
With oCtrl
If CLng(aCtrlColWidths(lColCounter)) = 0 Then
sColWidths = sColWidths & 0 & ";"
Else
sColWidths = sColWidths & aMaxColEntries(lColCounter, 0) + lBuffer & ";"
lTotalReqWidth = lTotalReqWidth + aMaxColEntries(lColCounter, 0) + lBuffer
End If
End With
Next lColCounter
Else
'Calculate Total Width Required
For lColCounter = 0 To lNoCols - 1
If CLng(aCtrlColWidths(lColCounter)) = 0 Then
lTotalReqWidth = lTotalReqWidth + 0
Else
lTotalReqWidth = lTotalReqWidth + aMaxColEntries(lColCounter, 0) + lBuffer
End If
Next lColCounter
For lColCounter = 0 To lNoCols - 1
If CLng(aCtrlColWidths(lColCounter)) = 0 Then
sColWidths = sColWidths & 0 & ";"
Else
sColWidths = sColWidths & (oCtrl.Width / lTotalReqWidth) * (aMaxColEntries(lColCounter, 0) + lBuffer) & ";"
End If
Next lColCounter
End If
oCtrl.ColumnWidths = sColWidths
If oCtrl.ControlType = acComboBox And lResizeTechnique = ExplicitSizing Then
oCtrl.ListWidth = lTotalReqWidth
Else
oCtrl.ListWidth = oCtrl.Width
End If
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Control_AutoSizeColumns" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
You use the same Enum, helper function as the previous example and it is used in the exact same manner.
Comparison
I decided to do a quick test or 2 to truly evaluate the performance difference.
Using 10,000 records in a combo box, the 1st approach took 0.4785062 to load Vs. the 2nd approach taking 7.1207778, for a % diff of 174.813%.
Using 100 records in a combo box, the 1st approach took 0.0084455 to load Vs. the 2nd approach taking 0.0743012, for a % diff of 159.174%.
So, as you can see, there is a performance cost if you want 100% certitude in the width calculation.