Adjust ListBox Column Widths with SpinButton Control

[gmaxey]

I've been working on a project which includes a 4 column userform listbox where columns 0 and 1 initially display the same data and often the data string is very long.


The initial column widths are "340 pt;340 pt;0 pt;0 pt"

With this setting often one or more data strings are cutoff. I wanted to let the user adjust (expand/contract) the column widths using a spinbutton as required to see the full string.

This is what I came up with and it works. Does anyone reading this know of a more efficient way?


Private Sub spinColumnWidths_SpinDown()
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
arrParts = Split(ListBox1.ColumnWidths, ";")
arrSubParts = Split(arrParts(0), " ")
If arrSubParts(0) > 100 Then
strColumnWidths = arrSubParts(0) - 10 & " pt;"
arrSubParts = Split(arrParts(1), " ")
strColumnWidths = strColumnWidths & arrSubParts(0) - 10 & " pt;0 pt; 0pt"
ListBox1.ColumnWidths = strColumnWidths
Else
Beep
End If
lbl_Exit:
Exit Sub
End Sub

Private Sub spinColumnWidths_SpinUp()
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
arrParts = Split(ListBox1.ColumnWidths, ";")
arrSubParts = Split(arrParts(0), " ")
strColumnWidths = arrSubParts(0) + 10 & " pt;"
arrSubParts = Split(arrParts(1), " ")
strColumnWidths = strColumnWidths & arrSubParts(0) + 10 & " pt;0 pt; 0pt"
ListBox1.ColumnWidths = strColumnWidths
lbl_Exit:
Exit Sub
End Sub

[Paul_Hossler]

Can you post a sample document with the userform, etc.?

[gmaxey]

16213

[Paul_Hossler]

Just a few minor changes




Option Explicit

Private Sub UserForm_Initialize()
With listFilesRenamed
.AddItem
.List(.ListCount - 1, 0) = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
.List(.ListCount - 1, 1) = "ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ"
.List(.ListCount - 1, 2) = "123"
.List(.ListCount - 1, 3) = "456"
.AddItem
.List(.ListCount - 1, 0) = "A"
.List(.ListCount - 1, 1) = "Z"
.List(.ListCount - 1, 2) = "789"
.List(.ListCount - 1, 3) = "000"
End With
lbl_Exit:
Exit Sub
End Sub

'Spinbuttons ********************************************************
Private Sub spinColumnWidths_SpinDown()
AdjSpinColumnWidths (-10)
lbl_Exit:
Exit Sub
End Sub

Private Sub spinColumnWidths_SpinUp()
AdjSpinColumnWidths (10)
lbl_Exit:
Exit Sub
End Sub


Private Sub AdjSpinColumnWidths(adj As Long)
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
Dim i As Long

arrParts = Split(listFilesRenamed.ColumnWidths, ";")
arrSubParts = Split(arrParts(0), " ")
strColumnWidths = arrSubParts(0) + adj & " " & arrSubParts(1) & ";"
For i = LBound(arrParts) + 1 To UBound(arrParts)
strColumnWidths = strColumnWidths & arrParts(i) & ";"
Next i
listFilesRenamed.ColumnWidths = Left(strColumnWidths, Len(strColumnWidths) - 1)
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Paul, Thanks for taking a look. Will probably make that a universal sub and pass the listbox to it.

[Paul_Hossler]

I was also thinking of passing a column number to it also

[gmaxey]

Paul,
Yes that is another good idea.


'Spinbuttons ********************************************************
Private Sub spinColumnWidths_SpinDown()
AdjListColumnWidths listFilesRenamed, "1,2", (-10)
lbl_Exit:
Exit Sub
End Sub

Private Sub spinColumnWidths_SpinUp()
AdjListColumnWidths listFilesRenamed, "1,2", (10)
lbl_Exit:
Exit Sub
End Sub


Private Sub AdjListColumnWidths(oList As Object, strCols As String, lngAdj As Long)
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
Dim lngIndex As Long

arrParts = Split(listFilesRenamed.ColumnWidths, ";")
arrSubParts = Split(arrParts(0), " ")
For lngIndex = LBound(arrParts) To UBound(arrParts)
If InStr(strCols, CStr(lngIndex + 1)) > 0 Then
strColumnWidths = strColumnWidths & arrSubParts(0) + lngAdj & " " & arrSubParts(1) & ";"
Else
strColumnWidths = strColumnWidths & arrParts(lngIndex) & ";"
End If
Next lngIndex
oList.ColumnWidths = Left(strColumnWidths, Len(strColumnWidths) - 1)
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Well it needs a lower limit, otherwise you can create an error situations:


Private Sub AdjListColumnWidths(oList As Object, strCols As String, lngAdj As Long)
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
Dim lngIndex As Long

arrParts = Split(listFilesRenamed.ColumnWidths, ";")
arrSubParts = Split(arrParts(0), " ")
For lngIndex = LBound(arrParts) To UBound(arrParts)
If InStr(strCols, CStr(lngIndex + 1)) > 0 Then
Select Case True
Case lngAdj < 0
If arrSubParts(0) > 100 Then
strColumnWidths = strColumnWidths & arrSubParts(0) + lngAdj & " " & arrSubParts(1) & ";"
Else
strColumnWidths = strColumnWidths & arrParts(lngIndex) & ";"
Beep
End If
Case Else
If arrSubParts(0) < 5000 Then
strColumnWidths = strColumnWidths & arrSubParts(0) + lngAdj & " " & arrSubParts(1) & ";"
Else
strColumnWidths = strColumnWidths & arrParts(lngIndex) & ";"
Beep
End If
End Select
Else
strColumnWidths = strColumnWidths & arrParts(lngIndex) & ";"
End If
Next lngIndex
oList.ColumnWidths = Left(strColumnWidths, Len(strColumnWidths) - 1)
lbl_Exit:
Exit Sub
End Sub

[Paul_Hossler]

some other things for you to consider




'Spinbuttons ********************************************************
Private Sub spinColumnWidths_SpinDown()
AdjListColumnWidths listFilesRenamed, 0, -10
lbl_Exit:
Exit Sub
End Sub

Private Sub spinColumnWidths_SpinUp()
AdjListColumnWidths listFilesRenamed, 0, 10
lbl_Exit:
Exit Sub
End Sub


'lngColNum 0 based
Private Sub AdjListColumnWidths(oList As msforms.ListBox, lngColNum As Long, lngAdj As Long)
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
Dim lngIndex As Long

On Error GoTo lbl_ErrHandle
If lngColNum < 0 Or lngColNum > oList.ColumnCount Then _
Call Err.Raise(vbObjectError + 1, "AdjListColumnWidths", "Col number passed out of range")

arrParts = Split(listFilesRenamed.ColumnWidths, ";")
arrSubParts = Split(arrParts(lngColNum), " ")

arrSubParts(0) = arrSubParts(0) + lngAdj

If arrSubParts(0) < 0 Or arrSubParts(0) > oList.Width Then _
Call Err.Raise(vbObjectError + 2, "AdjListColumnWidths", "Adjusted Col size out of range")

arrParts(lngColNum) = arrSubParts(0) & " " & arrSubParts(1)

strColumnWidths = Join(arrParts, ";")

oList.ColumnWidths = strColumnWidths

lbl_ErrHandle:
Err.Clear
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Paul,

Perhaps it wasn't clear or perhaps it didn't work in the doc I attached, but I needed the code to expand/contract two adjacent columns. Accordingly, I am now using this:


Private Sub spinColumnWidths_SpinDown()
AdjListColumnWidths listFilesRenamed, "0,1", -10
lbl_Exit:
Exit Sub
End Sub

Private Sub spinColumnWidths_SpinUp()
AdjListColumnWidths listFilesRenamed, "0,1", 10
lbl_Exit:
Exit Sub
End Sub


'lngColNum 0 based
Private Sub AdjListColumnWidths(oList As MSForms.ListBox, strCols As String, lngAdj As Long)
Dim arrParts() As String, arrSubParts() As String
Dim strColumnWidths As String
Dim lngIndex As Long
Dim arrCols() As String
Dim lngCol As Long
arrCols = Split(strCols, ",")
On Error GoTo lbl_ErrHandle
arrParts = Split(oList.ColumnWidths, ";")
For lngIndex = 0 To UBound(arrCols)
lngCol = arrCols(lngIndex)
If lngCol < 0 Or lngCol > oList.ColumnCount Then
Err.Raise vbObjectError + 1
End If
Next lngIndex
For lngIndex = 0 To UBound(arrCols)
arrSubParts = Split(arrParts(arrCols(lngIndex)), " ")
arrSubParts(0) = arrSubParts(0) + lngAdj
If arrSubParts(0) < 100 Then
Else
arrParts(arrCols(lngIndex)) = arrSubParts(0) & " " & arrSubParts(1)
End If
Next
strColumnWidths = Join(arrParts, ";")
oList.ColumnWidths = strColumnWidths
lbl_Exit:
Exit Sub
lbl_ErrHandle:
Beep
Select Case Err.Number
Case 13: Debug.Print "Type mismatch. Pass a numerical value from 0 to 1 less than the total column count."
Case Else: Debug.Print "Out of range. List box columns are indexed from 0. Pass a numerical value from 0 to 1 less than the total column count."
End Select
Resume lbl_Exit
End Sub



Thanks for your thoughts and feedback.

[Paul_Hossler]

Perhaps it wasn't clear or perhaps it didn't work in the doc I attached, but I needed the code to expand/contract two adjacent columns. Accordingly, I am now using this:


Oh .. I missed the 2 col aspect. I was wondering about the "1,2" in your call