Expand structured parts list based on cell value

[Inventor_Enjoyer]

Hi, I'm currently working on vba macro that would expand parts list based on cell value. So if any subassembly contains parts or subassemblies with cell value anything else than "No" it would then expand parts list.

This is my code currently:

Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    Dim oPartlist As PartsList
    Set oPartlist = oSheet.PartsLists.Item(1)
    Dim i As Long
    Dim FirstRowCount As Integer
    Dim LastRowCount As Integer
    Do Until FirstRowCount = LastRowCount
        FirstRowCount = oPartlist.PartsListRows.Count
        For i = 1 To oPartlist.PartsListRows.Count
            Dim oCell As PartsListCell
            Set oCell = oPartlist.PartsListRows.Item(i).Item("Part Type")
                    If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
                    oPartlist.PartsListRows.Item(i).Expanded = True
                    End If
            Next
            LastRowCount = oPartlist.PartsListRows.Count
    Loop
     

But it doesn't do anything. So any heads up where the problem might be?

[Dev_rim]

Hi there, 

The main mistake in the code you are using Do Until but both values are empty. So basically all FirstRowCount and LastRowCount things are equal to 0.

So it will never do the process inside of the Do Until. You should assign them different values. 

I dont know is there a special reason for using Do Until but, How about this?

Sub main()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    Dim oPartlist As PartsList
    Set oPartlist = oSheet.PartsLists.Item(1)
    Dim i As Integer
    Dim row As PartListRow
    For Each row In oPartlist.PartsListRows
        Dim oCell As PartsListCell
        Set oCell = row.Item("Part Type")
        If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
            row.Expanded = True
        End If
    Next row
End Sub

This sub will expand all rows which have "Spare part" or "Wear part" values on "Part Type") cell.

Also if you want to expand every row which have values different than "No" on "Part Type" cell you can use this code:

Sub main()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    Dim oPartlist As PartsList
    Set oPartlist = oSheet.PartsLists.Item(1)
    Dim i As Integer
    Dim row As PartListRow
    For Each row In oPartlist.PartsListRows
        Dim oCell As PartsListCell
        Set oCell = row.Item("Part Type")
        If Not oCell.Value = "No" Then
            row.Expanded = True
        End If
    Next row
End Sub

Regards

Devrim

[Inventor_Enjoyer]

Hi, your code works to some extend but after few rows it gives this error

[Dev_rim]

Can you please debug and show in which step is broken.

I did not test it because i dont have drawing file on the machine. If you can share it i can look.

Also maybe you can try code like this

Sub main()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    Dim oPartlist As PartsList
    Set oPartlist = oSheet.PartsLists.Item(1)
    Dim i As Integer
    Dim row As PartListRow
    For Each row In oPartlist.PartsListRows
        On Error Resume Next
        Dim oCell As PartsListCell
        Set oCell = row.Item("Part Type")
        If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
            row.Expanded = True
        End If
    Next row
End Sub

 Also if you have error again, please move the 'On Error Resume Next' line to second line

[Inventor_Enjoyer]

Hi, this is where it shows the error. Hovering mouse over it the value is "False"

[Dev_rim]

The last solution to this without example files, is this:

Sub main()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    Dim oPartlist As PartsList
    Set oPartlist = oSheet.PartsLists.Item(1)
    Dim i As Integer
    For i = 1 To oPartlist.PartsListRows.Count + 1
        On Error Resume Next
        Dim oCell As PartsListCell
        Set oCell = oPartlist.PartsListRows.Item(i).Item("Part Type")
        If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
            oPartlist.PartsListRows.Item(i).Expanded = True
        End If
    Next
End Sub

Also you can try this with 'On Error Resume Next' right below the beginning of the sub, for or if.

This is all I can do now without file.

Regards 

Devrim

[Inventor_Enjoyer]

Hi, now it works fine, but there's still some assemblies which aren't expanded. I guess now it is expanding assembly if the assembly is marked as spare or wear part? I would like it to expand to more deep level like shown in picture ( I expanded this manually.)

[Dev_rim]

I hope this will solve the issue.

I really dont know the topic and I just tried. This is the best I can do. I can not test it because I dont have any drawings.

Please test this and use if it works. If not, throw it away 🙂

Sub main()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    Dim oPartlist As PartsList
    Set oPartlist = oSheet.PartsLists.Item(1)
    Dim i As Integer
    For i = 1 To oPartlist.PartsListRows.Count + 1
        On Error Resume Next
        Dim oCell As PartsListCell
        Set oCell = oPartlist.PartsListRows.Item(i).Item("Part Type")
        If Not oCell.Value = "No" Then
            oPartlist.PartsListRows.Item(i).Expanded = True
        End If
        Dim j As Integer
        For j = 1 To oPartlist.PartsListRows.Item(i).ReferencedRows.Count + 1
            On Error Resume Next
            Dim bomRow As DrawingBOMRow
            bomRow = oPartlist.PartsListRows.Item(i).ReferencedRows.Item(j)
            Dim k As Integer
            For k = 1 To bomRow.Count + 1
                Dim bomCell As DrawingBOMCell
                bomCell = bomRow.Item("Part Type")
                If Not bomCell.Value = "No" And oPartlist.PartsListRows.Item(i).Expanded = False Then
                    oPartlist.PartsListRows.Item(i).Expanded = True
                    Exit For
                End If
            Next
        Next
    Next
End Sub

[Inventor_Enjoyer]

Hi. This works pretty well, but I think it needs "Do Until" or some kin of loop, because it doesn't expand all the way to the bottom.

[Inventor_Enjoyer]

Also I noted that if I remove "On Error Resume Next" the value for bomRow is nothing?

[Inventor_Enjoyer]

I was looking into this and found out that problem is in the counter. This code works fine but it doesn't take expanded rows into action. I thought that maybe if you can somehow add count to in the beginning and to the end and loop it using Do Until.

I figured this by changing

For i = 1 To oPartlist.PartsListRows.Count + 1

to

For i = 1 To 999

But it isn't right way to do this I guess 😁.