Parts List Column Fitting

[harvey3ELEA]

I've been using this handy little code (from this forum) for condensing column widths of my various parts lists in my 10-sheet drawing.  Code works great as it updates all 10 sheets at one time, but I'm looking to modify the code as to where it will do the column update on the current sheet (of the 10) I'm working on.

I'm not super skilled at iLogic so I'm not sure which command(s) I would need to change to accomplish the single sheet column update.  Suggestions welcomed!

Sub Main()
	If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
		MessageBox.Show("Hey the rule only runs in drawing documents!")
		Exit Sub
	End If
	
	Dim oDrawDoc As DrawingDocument
	oDrawDoc = ThisApplication.ActiveDocument
	Dim oSheet As Sheet
	'Create sheet counter variable
	Dim iSheetCount As Integer
	iSheetCount = 0
	Dim oProgressBar As Inventor.ProgressBar

	'Progress bar
	oMessage = "Organizing All Parts List"
	Dim SheetCount As Integer
	SheetCount = oDrawDoc.Sheets.Count
	
	oProgressBar = ThisApplication.CreateProgressBar(False, SheetCount, oMessage, True) 'True = Cancel button
	
	For Each oSheet In oDrawDoc.Sheets			
		
		For Each oPL As PartsList In oSheet.PartsLists		
			
			'Get the current sheet number
			iSheetCount = iSheetCount + 1
			
			'Update the progress bar to reflect which sheet is being operated on
			oProgressBar.Message = ("Processing Sheet " & iSheetCount & " of " & SheetCount & "...")
			oProgressBar.UpdateProgress
			
			'Sort Parts List By:
			oPL.Sort("PART #")
			oPL.Renumber
				
			'Call Sub	
			PartsListFitColumns(oPL)	
				
		Next
	
	Next
	
	oProgressBar.Close

End Sub

'Fit columns of parts list
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)
		For Each oRow In oPartsList.PartsListRows
			If oRow.Visible = True Then
					sData = oRow.Item(iCol).Value ' get the data from the cell	
					If Len(sData) > iLen(iCol) Then
						iLen(iCol) = Len(sData)
					End If
			End If
		Next oRow
		
		Dim col_l As Double = oPartsList.PartsListColumns(iCol).Width
		Dim desired_col_l = dWidth * (iLen(iCol) + 2)
		Dim ratio1 As Double = 0.85
		Dim ratio2 As Double = 0.8
		Dim ratio3 As Double = 0.75
		Dim ratio4 As Double = 0.7
		Dim ratio5 As Double = 0.62
		
		'messagebox.Show(iLen(iCol))
		
		Select Case iLen(iCol)
			Case <= 10
				If col_l <> desired_col_l * ratio1  Then
	            	oPartsList.PartsListColumns(iCol).Width = desired_col_l * ratio1
	        	End If
			Case 11 To 20
				If col_l <> desired_col_l * ratio2  Then
	            	oPartsList.PartsListColumns(iCol).Width = desired_col_l * ratio2
	        	End If
			Case 21 To 30
				If col_l <> desired_col_l * ratio3  Then
	            	oPartsList.PartsListColumns(iCol).Width = desired_col_l * ratio3
	        	End If
			Case 31 To 40
				If col_l <> desired_col_l * ratio4  Then
	            	oPartsList.PartsListColumns(iCol).Width = desired_col_l * ratio4
	        	End If
			Case >= 41
				If col_l <> desired_col_l * ratio5  Then
	            	oPartsList.PartsListColumns(iCol).Width = desired_col_l * ratio5
	        	End If
			
		End Select		
		
	Next iCol	
	
	Return oPartsList
End Function

[Michael.Navara]

This is modification of relevant part - NOT TESTED!!!

	'For Each oSheet In oDrawDoc.Sheets  'Comment out	
	Dim oSheet = oDrawDoc.ActiveSheet 'Add	
		For Each oPL As PartsList In oSheet.PartsLists		
			
			'Get the current sheet number
			' .... Keep unchanged	
				
		Next
	
	' Next 'Comment out

[WCrihfield]

Hi @harvey3ELEA.  Besides what Michael already mentioned, you would likely also want to get rid of all the ProgressBar related stuff, and stuff having to do with multiple sheets, like the sheet count.  I have used a different version of this same code based process for years now, but my version does not use multiple specific ratios like yours, because it did not seem to be needed in my drawings.  But there are lots of possible differences in drawing styles and fonts being used, which can change how all that stuff works together, so its likely not a 'one size fits all' type situation.

Anyways, I copied your original code, then modified it in several areas, mostly to condense it and make it more efficient.  But I left all the mathematical calculations so that they will work exactly the same as before, but will less code and calculations involved.  Before it was doing the same calculations twice, but now just once.  The original code was also obtaining the columns collection, and the one column in many different places, but now is just obtaining those once, then using that variable for all needs after that point, which will result in less processing.  Give this version a try, and see if it works OK for you.

Sub Main
	Dim oDDoc As DrawingDocument = TryCast(ThisApplication.ActiveDocument, Inventor.DrawingDocument)
	If oDDoc Is Nothing Then
		MessageBox.Show("Hey the rule only runs in drawing documents!")
		Return
	End If
	For Each oPL As PartsList In oDDoc.ActiveSheet.PartsLists
		'Sort Parts List By:
		oPL.Sort("PART #")
		oPL.Renumber
		'Call Sub	
		PartsListFitColumns(oPL)
	Next
	oDDoc.Update2(True)
End Sub

'Fit columns of parts list
Public Sub PartsListFitColumns(oPList As PartsList)
	If oPList Is Nothing Then Return
	Dim oCols As PartsListColumns = oPList.PartsListColumns
	' get font info	
	Dim dWidth As Double = oPList.DataTextStyle.FontSize * oPList.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 = oCols.Count
	' Set up array To hold column widths
	Dim iLen() As Integer
	ReDim iLen(iCols)
	' initialize to header lengths
	For iCol = 1 To iCols
		Dim oCol As PartsListColumn = oCols.Item(iCol)
		iLen(iCol) = Len(oCol.Title)
		For Each oRow In oPList.PartsListRows
			If oRow.Visible = True Then
				sData = oRow.Item(iCol).Value ' get the data from the cell	
				If Len(sData) > iLen(iCol) Then
					iLen(iCol) = Len(sData)
				End If
			End If
		Next oRow
		Dim col_l As Double = oCol.Width
		Dim desired_col_l = dWidth * (iLen(iCol) + 2)
		Dim ScaledColW1 As Double = desired_col_l * 0.85
		Dim ScaledColW2 As Double = desired_col_l * 0.8
		Dim ScaledColW3 As Double = desired_col_l * 0.75
		Dim ScaledColW4 As Double = desired_col_l * 0.7
		Dim ScaledColW5 As Double = desired_col_l * 0.62
		'messagebox.Show(iLen(iCol))
		Select Case iLen(iCol)
			Case <= 10
				If col_l <> ScaledColW1 Then oCol.Width = ScaledColW1
			Case 11 To 20
				If col_l <> ScaledColW2 Then oCol.Width = ScaledColW2
			Case 21 To 30
				If col_l <> ScaledColW3 Then oCol.Width = ScaledColW3
			Case 31 To 40
				If col_l <> ScaledColW4 Then oCol.Width = ScaledColW4
			Case >= 41
				If col_l <> ScaledColW5 Then oCol.Width = ScaledColW5
		End Select
	Next iCol
End Sub

If this solved your problem, or answered your question, please click ACCEPT SOLUTION .
Or, if this helped you, please click (LIKE or KUDOS) 👍.

[harvey3ELEA]

Thanks, Wesley.  Heading out of the office a bit early, but I will give your code a run tomorrow morning and let you know how it's working.  Harvey