layer change in drawing with respect to category specified in subassembly

[sujit_jangra]

Dear All, I have prepared an ilogic rule to change layer in drawing as per bill of material, now I need help to change it VIA category (iPoperties>Summary>Category)
If Category contains
X1 then change that with AM_2
X2 then change that with AM_1
X3 then change that with AM_11
X4 then change that with AM_5

Sub Main()
' Ensure the active document is a drawing document
If ThisApplication.ActiveDocumentType <> DocumentTypeEnum.kDrawingDocumentObject Then
Call MsgBox("This macro only works on drawing documents.", vbExclamation, "Error")
Exit Sub
End If

' Get the active drawing document
Dim oDoc As DrawingDocument
oDoc = ThisApplication.ActiveDocument

' Get all layers in the drawing
Dim oLayers As LayersEnumerator
oLayers = oDoc.StylesManager.Layers

' Define the target layer
Dim TargetLayer As String
TargetLayer = "AM_1" ' Change this to your desired layer name

' Find the target layer
Dim oLayer As Layer = Nothing
For Each xLayer As Layer In oLayers
If xLayer.Name = TargetLayer Then
oLayer = xLayer
Exit For
End If
Next

' If the target layer doesn't exist, show an error and exit
If oLayer Is Nothing Then
Call MsgBox("Layer '" & TargetLayer & "' not found.", vbExclamation, "Error")
Exit Sub
End If

' Start a transaction for undo support
Dim oTrans As Transaction
oTrans = ThisApplication.TransactionManager.StartTransaction(oDoc, "Move Purchased Parts to Layer")

' Loop through all sheets in the drawing
For Each sheet As Sheet In oDoc.Sheets
For Each view As DrawingView In Sheet.DrawingViews
' Check if the view has a valid reference
If View.ReferencedDocumentDescriptor Is Nothing Then
Continue For
End If

' Get the component definition from the view
Dim refAssyDef As ComponentDefinition
If View.ReferencedDocumentDescriptor.ReferencedDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
refAssyDef = View.ReferencedDocumentDescriptor.ReferencedDocument.ComponentDefinition
Else
Continue For
End If

' Ensure the reference is valid
If refAssyDef Is Nothing Then
Continue For
End If

' Process all occurrences (including subassemblies)
ProcessOccurrences(refAssyDef.Occurrences, View, oLayer)
Next
Next

' End the transaction
oTrans.End()

' Notify the user
Call MsgBox("Purchased parts moved to layer '" & TargetLayer & "'.", vbInformation, "Completed")
End Sub

' --- Recursive Function to Process Subassemblies and Parts ---
Sub ProcessOccurrences(ByVal occurrences As ComponentOccurrences, ByVal view As DrawingView, ByVal oLayer As Layer)
For Each occurrence As ComponentOccurrence In occurrences
' ‌‌ FIX: Ensure we only access SubOccurrences for assemblies
If occurrence.DefinitionDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
Try
' ‌‌ Use `ReferencedDocumentDescriptor.ReferencedDocument` instead of `ReferencedDocument`
Dim refDoc As Document = Nothing
If occurrence.ReferencedDocumentDescriptor IsNot Nothing Then
refDoc = occurrence.ReferencedDocumentDescriptor.ReferencedDocument
End If

' ‌‌ Ensure the referenced document is valid
If refDoc Is Nothing Then
Call MsgBox("Skipping: " & occurrence.Name & " (No valid referenced document)", vbExclamation, "Warning")
Continue For
End If

' ‌‌ Ensure SubOccurrences exist and are not empty
If occurrence.SubOccurrences IsNot Nothing AndAlso occurrence.SubOccurrences.Count > 0 Then
ProcessOccurrences(occurrence.SubOccurrences, view, oLayer)
Else
Call MsgBox("Skipping: " & occurrence.Name & " (No sub-occurrences)", vbExclamation, "Info")
End If

Catch ex As Exception
Call MsgBox("Error accessing subassemblies for: " & occurrence.Name & vbCrLf & ex.Message, vbExclamation, "Error")
Continue For
End Try
Else
' If it's a purchased part, move it to the layer
If occurrence.BOMStructure = BOMStructureEnum.kPurchasedBOMStructure Then
Try
' Check if there are drawing curves for this occurrence
Dim ViewCurves As DrawingCurvesEnumerator = Nothing
If view Is Nothing OrElse occurrence Is Nothing Then
Continue For
End If

' Attempt to get drawing curves
Try
ViewCurves = view.DrawingCurves(occurrence)
Catch
' Skip occurrences that don't have drawing curves
Continue For
End Try

' If no curves exist, continue to the next occurrence
If ViewCurves Is Nothing OrElse ViewCurves.Count = 0 Then
Continue For
End If

' Move the purchased part curves to the target layer
For Each c As DrawingCurve In ViewCurves
For Each segment As DrawingCurveSegment In c.Segments
' Ensure the segment has a valid layer before modifying it
If segment.Layer IsNot Nothing AndAlso segment.Layer.LineType = 37633 Then
segment.Layer = oLayer
End If
Next
Next
Catch ex As Exception
Call MsgBox("Error processing part: " & occurrence.Name & vbCrLf & ex.Message, vbExclamation, "Error")
End Try
End If
End If
Next
End Sub

[_dscholtes_]

Well, there are a couple of things that needs to change:

1. Instead of checking for the existence of 1 target layer, you should check the existence of the prescribed 4.
2. Instead of passing 1 layer to the recursive function (oLayer), you should pass the new 4 layers. I'd probably put the 4 layer objects in an object collection and pass the collection.
3. Instead of checking if the object is a purchase part, you should check the existence and value of the Category property.
4. When you have retrieved the corresponding drawing curves of the object, you need to set them to the correct layer.

Edit:

Please post the code in a code block next time, with proper indentation as well. Makes it a lot easier to read or to comment.
You can find it in the message toolbar under the ... (expand toolbar) and then </> (insert/edit code example) and choose visual basic as language.

[sujit_jangra]

Facing error with code

Sub Main()
    ' Ensure the active document is a drawing document
    If ThisApplication.ActiveDocumentType <> DocumentTypeEnum.kDrawingDocumentObject Then
        Call MsgBox("This macro only works on drawing documents.", vbExclamation, "Error")
        Exit Sub
    End If

    ' Get the active drawing document
    Dim oDoc As DrawingDocument
    oDoc = ThisApplication.ActiveDocument

    ' Get all layers in the drawing
    Dim oLayers As LayersEnumerator
    oLayers = oDoc.StylesManager.Layers

    ' Define the layer mappings based on Category
    Dim LayerMap As New Dictionary(Of String, String)
    LayerMap.Add("CIVIL", "AM_2")
    LayerMap.Add("GPI", "AM_1")
    LayerMap.Add("X3", "AM_11")
    LayerMap.Add("CLIENT", "Reference")

    ' Retrieve layers based on mapping
    Dim TargetLayers As New Dictionary(Of String, Layer)
    For Each key As String In LayerMap.Keys
        TargetLayers(key) = Nothing
        For Each xLayer As Layer In oLayers
            If xLayer.Name = LayerMap(key) Then
                TargetLayers(key) = xLayer
                Exit For
            End If
        Next
        If TargetLayers(key) Is Nothing AndAlso key <> "CLIENT" Then
            Call MsgBox("Layer '" & LayerMap(key) & "' not found.", vbExclamation, "Error")
            Exit Sub
        End If
    Next

    ' Start a transaction for undo support
    Dim oTrans As Transaction
    oTrans = ThisApplication.TransactionManager.StartTransaction(oDoc, "Move Items to Layers")

    ' Loop through all sheets in the drawing
    For Each sheet As Sheet In oDoc.Sheets
        For Each view As DrawingView In Sheet.DrawingViews
            ' Ensure the view has a valid reference
            If View.ReferencedDocumentDescriptor Is Nothing Then
                Continue For
            End If

            ' Get the component definition from the view
            Dim refAssyDef As ComponentDefinition
            If View.ReferencedDocumentDescriptor.ReferencedDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
                refAssyDef = View.ReferencedDocumentDescriptor.ReferencedDocument.ComponentDefinition
            Else
                Continue For
            End If

            ' Ensure the reference is valid
            If refAssyDef Is Nothing Then
                Continue For
            End If

            ' Process all occurrences
            ProcessOccurrences(refAssyDef.Occurrences, View, TargetLayers)
        Next
    Next

    ' End the transaction
    oTrans.End()

    ' Notify the user
    Call MsgBox("Items moved to respective layers based on Category.", vbInformation, "Completed")
End Sub

' --- Recursive Function to Process Subassemblies and Parts ---
Sub ProcessOccurrences(ByVal occurrences As ComponentOccurrences, ByVal view As DrawingView, ByVal TargetLayers As Dictionary(Of String, Layer))
    Dim ClientOccurrencesList As New Collection ' Store occurrences with "CLIENT" category

    For Each occurrence As ComponentOccurrence In occurrences
        ' Check for subassemblies
        If occurrence.DefinitionDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            ProcessOccurrences(occurrence.SubOccurrences, view, TargetLayers)
        Else
            ' Check the "Category" property
            Try
                ' Validate that PropertySets exists
                If Not TypeOf occurrence Is ComponentOccurrence Then
                    Call MsgBox("Invalid occurrence type: " & occurrence.Name, vbExclamation, "Error")
                    Continue For
                End If

                Dim Category As String = ""
                If occurrence.PropertySets Is Nothing OrElse Not occurrence.PropertySets("Design Tracking Properties").Contains("Category") Then
                    Category = "UNKNOWN"
                Else
                    Category = occurrence.PropertySets("Design Tracking Properties")("Category").Value
                End If

                If TargetLayers.ContainsKey(Category) Then
                    If Category = "CLIENT" Then
                        ' Check Vault Checkout Status
                        Dim isCheckedOut As Boolean = False
                        If occurrence.ReferencedDocumentDescriptor.ReferencedDocument IsNot Nothing Then
                            isCheckedOut = occurrence.ReferencedDocumentDescriptor.ReferencedDocument.IsCheckedOut
                        End If

                        If Not isCheckedOut Then
                            ClientOccurrencesList.Add(occurrence.Name)
                        End If

                        ' Skip further processing for "CLIENT"
                        Continue For
                    End If

                    ' Get drawing curves
                    Dim ViewCurves As DrawingCurvesEnumerator = Nothing
                    Try
                        ViewCurves = view.DrawingCurves(occurrence)
                    Catch
                        Continue For
                    End Try

                    ' Move curves to the correct layer
                    If ViewCurves IsNot Nothing AndAlso ViewCurves.Count > 0 Then
                        For Each c As DrawingCurve In ViewCurves
                            For Each segment As DrawingCurveSegment In c.Segments
                                segment.Layer = TargetLayers(Category)
                            Next
                        Next
                    End If
                End If
            Catch ex As Exception
                Call MsgBox("Error processing part: " & occurrence.Name & vbCrLf & ex.Message, vbExclamation, "Error")
            End Try
        End If
    Next

    ' Prompt user to check out "CLIENT" occurrences
    If ClientOccurrencesList.Count > 0 Then
        Dim message As String
        message = "The following CLIENT occurrences are not checked out from Vault:" & vbCrLf
        For Each occurrenceName As String In ClientOccurrencesList
            message = message & "- " & occurrenceName & vbCrLf
        Next
        message = message & vbCrLf & "Please check them out before proceeding."
        Call MsgBox(message, vbInformation, "Check Out Required")
    End If
End Sub

[sujit_jangra]

kindly review

[mateusz_baczewski]

Hi @sujit_jangra 

Please check this code. The problem you mentioned is caused by the fact that ComponentOccurrence does not contain the PropertySet property/method. To verify this, you need to reference the document of the given occurrence, and then everything should work correctly.

Sub Main()
    ' Ensure the active document is a drawing document
    If ThisApplication.ActiveDocumentType <> DocumentTypeEnum.kDrawingDocumentObject Then
        Call MsgBox("This macro only works on drawing documents.", vbExclamation, "Error")
        Exit Sub
    End If

    ' Get the active drawing document
    Dim oDoc As DrawingDocument
    oDoc = ThisApplication.ActiveDocument

    ' Get all layers in the drawing
    Dim oLayers As LayersEnumerator
    oLayers = oDoc.StylesManager.Layers

    ' Define the layer mappings based on Category
    Dim LayerMap As New Dictionary(Of String, String)
    LayerMap.Add("CIVIL", "AM_2")
    LayerMap.Add("GPI", "AM_1")
    LayerMap.Add("X3", "AM_11")
    LayerMap.Add("CLIENT", "Reference")

    ' Retrieve layers based on mapping
    Dim TargetLayers As New Dictionary(Of String, Layer)
    For Each key As String In LayerMap.Keys
        TargetLayers(key) = Nothing
        For Each xLayer As Layer In oLayers
            If xLayer.Name = LayerMap(key) Then
                TargetLayers(key) = xLayer
                Exit For
            End If
        Next
        If TargetLayers(key) Is Nothing AndAlso key <> "CLIENT" Then
            Call MsgBox("Layer '" & LayerMap(key) & "' not found.", vbExclamation, "Error")
            Exit Sub
        End If
    Next

    ' Start a transaction for undo support
    Dim oTrans As Transaction
    oTrans = ThisApplication.TransactionManager.StartTransaction(oDoc, "Move Items to Layers")

    ' Loop through all sheets in the drawing
    For Each sheet As Sheet In oDoc.Sheets
        For Each view As DrawingView In Sheet.DrawingViews
            ' Ensure the view has a valid reference
            If View.ReferencedDocumentDescriptor Is Nothing Then
                Continue For
            End If

            ' Get the component definition from the view
            Dim refAssyDef As ComponentDefinition
            If View.ReferencedDocumentDescriptor.ReferencedDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
                refAssyDef = View.ReferencedDocumentDescriptor.ReferencedDocument.ComponentDefinition
            Else
                Continue For
            End If

            ' Ensure the reference is valid
            If refAssyDef Is Nothing Then
                Continue For
            End If

            ' Process all occurrences
            ProcessOccurrences(refAssyDef.Occurrences, View, TargetLayers)
        Next
    Next

    ' End the transaction
    oTrans.End()

    ' Notify the user
    Call MsgBox("Items moved to respective layers based on Category.", vbInformation, "Completed")
End Sub

' --- Recursive Function to Process Subassemblies and Parts ---
Sub ProcessOccurrences(ByVal occurrences As ComponentOccurrences, ByVal view As DrawingView, ByVal TargetLayers As Dictionary(Of String, Layer))
    Dim ClientOccurrencesList As New Collection ' Store occurrences with "CLIENT" category

    For Each occurrence As ComponentOccurrence In occurrences
        ' Check for subassemblies
        If occurrence.DefinitionDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            ProcessOccurrences(occurrence.SubOccurrences, view, TargetLayers)
        Else
            ' Check the "Category" property
            Try
                ' Validate that PropertySets exists
                If Not TypeOf occurrence Is ComponentOccurrence Then
                    Call MsgBox("Invalid occurrence type: " & occurrence.Name, vbExclamation, "Error")
                    Continue For
                End If

                Dim Category As String = ""
                If occurrence.ReferencedDocumentDescriptor.ReferencedDocument.PropertySets Is Nothing _
					OrElse Not occurrence.ReferencedDocumentDescriptor.ReferencedDocument.PropertySets("Design Tracking Properties").Contains("Category") Then
                    Category = "UNKNOWN"
                Else
                    Category = occurrence.ReferencedDocumentDescriptor.ReferencedDocument.PropertySets("Design Tracking Properties")("Category").Value
                End If

                If TargetLayers.ContainsKey(Category) Then
                    If Category = "CLIENT" Then
                        ' Check Vault Checkout Status
                        Dim isCheckedOut As Boolean = False
                        If occurrence.ReferencedDocumentDescriptor.ReferencedDocument IsNot Nothing Then
                            isCheckedOut = occurrence.ReferencedDocumentDescriptor.ReferencedDocument.IsCheckedOut
                        End If

                        If Not isCheckedOut Then
                            ClientOccurrencesList.Add(occurrence.Name)
                        End If

                        ' Skip further processing for "CLIENT"
                        Continue For
                    End If

                    ' Get drawing curves
                    Dim ViewCurves As DrawingCurvesEnumerator = Nothing
                    Try
                        ViewCurves = view.DrawingCurves(occurrence)
                    Catch
                        Continue For
                    End Try

                    ' Move curves to the correct layer
                    If ViewCurves IsNot Nothing AndAlso ViewCurves.Count > 0 Then
                        For Each c As DrawingCurve In ViewCurves
                            For Each segment As DrawingCurveSegment In c.Segments
                                segment.Layer = TargetLayers(Category)
                            Next
                        Next
                    End If
                End If
            Catch ex As Exception
                Call MsgBox("Error processing part: " & occurrence.Name & vbCrLf & ex.Message, vbExclamation, "Error")
            End Try
        End If
    Next

    ' Prompt user to check out "CLIENT" occurrences
    If ClientOccurrencesList.Count > 0 Then
        Dim message As String
        message = "The following CLIENT occurrences are not checked out from Vault:" & vbCrLf
        For Each occurrenceName As String In ClientOccurrencesList
            message = message & "- " & occurrenceName & vbCrLf
        Next
        message = message & vbCrLf & "Please check them out before proceeding."
        Call MsgBox(message, vbInformation, "Check Out Required")
    End If
End Sub

[sujit_jangra]

thank you for reverting, however same error coming