Fit parts list columns macro

[Anonymous]

Tired of having to manually resize your parts list columns? Wish that ADSK would implement an auto-fit, but can't wait for it to be added? Then try this handy dandy macro! (Use at your own risk, side effects may include giddiness, more free time, and uncontrollable urge to hug your computer)


--------------------------------------------------------------------------




Public Function PartsListFitColumns(oPartsList As PartsList) As PartsList

If oPartsList Is Nothing Then Exit Function

' get font info
Dim dWidth As Double
dWidth = oPartsList.DataTextStyle.FontSize * oPartsList.DataTextStyle.WidthScale

' find longest string in each column and resize column
Dim oRow As PartsListRow
Dim sData As String
Dim iCol As Integer
Dim iCols As Integer

iCols = oPartsList.PartsListColumns.Count

' set up array to hold column widths
Dim iLen() As Integer
ReDim iLen(iCols)

' initialize to header lengths
For iCol = 1 To iCols
iLen(iCol) = Len(oPartsList.PartsListColumns(iCol).Title)
Next iCol

' loop thru each row
For Each oRow In oPartsList.PartsListRows

If oRow.visible = True Then
For iCol = 1 To iCols

sData = oRow.Item(iCol).Value ' get the data from the cell

If Len(sData) > iLen(iCol) Then
iLen(iCol) = Len(sData)
End If

Next iCol
End If

Next oRow

' resize the columns (note add extra 2 character width for padding)
For iCol = 1 To iCols
oPartsList.PartsListColumns(iCol).Width = dWidth * (iLen(iCol) + 2)
Next iCol

Set PartsListFitColumns = oPartsList

End Function

[Anonymous]

Here is a simple way to use the macro, just select a parts list and then run the Sub below

(ALSO, this works best if you are using a monospace font, I don't know how it will work for a variable width font)

--------------------------------------------------------------------

Public Sub PartsListSelectedFitColumns()

Dim oPartsList As PartsList
Set oPartsList = GetSelectedPartsList
If oPartsList Is Nothing Then Exit Sub

PartsListFitColumns oPartsList

End Sub




Public Function GetSelectedPartsList() As PartsList

Dim oDrawDoc As DrawingDocument
Set oDrawDoc = GetActiveDrawing
If oDrawDoc Is Nothing Then Exit Function

Dim oSelectSet As SelectSet
Set oSelectSet = oDrawDoc.SelectSet

If oSelectSet.Count = 0 Then Exit Function
If oSelectSet.Item(1).Type <> kPartsListObject Then Exit Function
Set GetSelectedPartsList = oSelectSet.Item(1)

End Function


Public Function GetActiveDrawing() As DrawingDocument

If ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
Set GetActiveDrawing = ThisApplication.ActiveDocument
Else
MsgBox "Must have a drawing active", vbOKOnly, "Error"
End If

End Function