Announcements

Starting in December, we will archive content from the community that is 10 years and older. This FAQ provides more information.

Community
Inventor Programming - iLogic, Macros, AddIns & Apprentice
Inventor iLogic, Macros, AddIns & Apprentice Forum. Share your knowledge, ask questions, and explore popular Inventor topics related to programming, creating add-ins, macros, working with the API or creating iLogic tools.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Expand structured parts list based on cell value

10 REPLIES 10
Reply
Message 1 of 11
Inventor_Enjoyer
471 Views, 10 Replies

Expand structured parts list based on cell value

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.

Inventor_Enjoyer_0-1668082684058.png

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?

 

 

10 REPLIES 10
Message 2 of 11
Dev_rim
in reply to: Inventor_Enjoyer

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

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards
Message 3 of 11
Inventor_Enjoyer
in reply to: Dev_rim

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

Inventor_Enjoyer_0-1668085124453.png

 

Message 4 of 11
Dev_rim
in reply to: Inventor_Enjoyer

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

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards
Message 5 of 11
Inventor_Enjoyer
in reply to: Dev_rim

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

Inventor_Enjoyer_0-1668086400031.png

 

Message 6 of 11
Dev_rim
in reply to: Inventor_Enjoyer

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

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards
Message 7 of 11

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.)

Inventor_Enjoyer_0-1668087978035.png

 

Message 8 of 11
Dev_rim
in reply to: Inventor_Enjoyer

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

 

 

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards
Message 9 of 11
Inventor_Enjoyer
in reply to: Dev_rim

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_1-1668151086982.png

 

 

 

Message 10 of 11
Inventor_Enjoyer
in reply to: Dev_rim

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

Inventor_Enjoyer_0-1668159261169.png

 

Message 11 of 11
Inventor_Enjoyer
in reply to: Dev_rim

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 😁.

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report