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]

Expand or Contract Column Width.docm

[Paul_Hossler]

Just a few minor changes

Option Explicit

Private Sub UserForm_Initialize()
  With listFilesRenamed
    .AddItem
    .List(.ListCount - 1, 0) = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
    .List(.ListCount - 1, 1) = "ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ"
    .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