suppress little parts in assembly using traverse and VBA

[harald.stratmann]

I want suppress parts in an assembly which have dimensions less then a defined cube.

(Little parts to have a better performance)

I modified example traverse assembly

For each assembly in assembly i will create a levelofdetail

Problem is in procedure Sub processAllSubOcc

I try following code:

Private Sub cmdAktionStarten_Click()

    Dim detail As String
    Dim kl As Double

    If Me.txtDetailgenauigkeit.Value = "" Then
        MsgBox "Bitte einen Namen für die Detailgenauigkeit angeben!"
    Else
        If Me.txtKantenlänge.Value = "" Then
            MsgBox "Bitte einen Wert für die Kantenlänge angeben!"
        Else
            detail = Me.txtDetailgenauigkeit.Value
            kl = CDbl(Me.txtKantenlänge.Value)
            BaugruppeKleinteileUnterdrücken kl, detail
        End If
    End If
    

kl = length of cube  for e.g. 50 x 50 x 50 mm

detail = name level detail  for e.g. "Layout"

End Sub

Sub BaugruppeKleinteileUnterdrücken(Kantenlänge As Double, bez As String)

    Dim x As Double
    Dim y As Double
    Dim z As Double
    
    x = Kantenlänge
    y = Kantenlänge
    z = Kantenlänge

    ' Set reference to active document.
    ' This assumes the active document is an assembly
    Dim oDoc As Inventor.AssemblyDocument
    Set oDoc = ThisApplication.ActiveDocument

    ' Get assembly component definition
    Dim oCompDef As Inventor.ComponentDefinition
    Set oCompDef = oDoc.ComponentDefinition
    
    ErzeugeDetailgenauigkeit oCompDef, bez

    ' Get all occurrences from component definition for Assembly document
    Dim oCompOcc As ComponentOccurrence
    For Each oCompOcc In oCompDef.Occurrences
        If Not oCompOcc.Suppressed Then
        
        
        ' Check if it's child occurrence (leaf node)
        If oCompOcc.SubOccurrences.Count = 0 Then
            Set oCompDef = oCompOcc.Definition
            If BauteilUnterdrücken(oCompDef, x, y, z) = True Then

'Here it works fine
                oCompOcc.Suppress
            End If
        Else
            
            Call processAllSubOcc(oCompOcc, _
                                bez, _
                                x, _
                                y, _
                                z) ' subassembly
        End If
        End If
    Next
    oDoc.Rebuild
    oDoc.Update
    oDoc.Save

End Sub

Private Sub processAllSubOcc(ByVal oCompOcc As ComponentOccurrence, _
                             ByVal bez As String, _
                             ByVal x As Double, _
                             ByVal y As Double, _
                             ByVal z As Double)
    
    Dim oSubCompOcc As ComponentOccurrence
    Dim oCompDef As Inventor.ComponentDefinition
    Dim oSubCompDef As Inventor.ComponentDefinition
    
    If oCompOcc.DefinitionDocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Set oCompDef = oCompOcc.Definition
            ErzeugeDetailgenauigkeit oCompDef, bez
            oCompOcc.SetLevelOfDetailRepresentation bez, True
    End If
        
    For Each oSubCompOcc In oCompOcc.SubOccurrences
        
        If Not oSubCompOcc.Suppressed Then
        Debug.Print oSubCompOcc.name
        ' Check if it's child occurrence (leaf node)
            If oSubCompOcc.SubOccurrences.Count = 0 Then
                Set oSubCompDef = oSubCompOcc.Definition
                If BauteilUnterdrücken(oSubCompDef, x, y, z) = True Then
 

'--------------------------------------------------------------------

' Here is the problem, after run suppress a new levelofdetail wil be created by system

' but the defined detail should be used

'------------------------------------------------------------------------

                    oSubCompOcc.Suppress
                    
                End If
            Else
                Call processAllSubOcc(oSubCompOcc, _
                                bez, _
                                  x, _
                                  y, _
                                  z)
            End If
        End If
    Next
    
End Sub

Function BauteilUnterdrücken(bauteil As ComponentDefinition, x As Double, y As Double, z As Double) As Boolean

    'Dim oDoc As Object
    'Dim oCompDef As ComponentDefinition
    'Set oDoc = ThisApplication.ActiveDocument
    Dim ax As Double
    Dim ay As Double
    Dim aZ As Double

    'Set oCompDef = oDoc.ComponentDefinition
    ax = 10 * (bauteil.RangeBox.MaxPoint.x - bauteil.RangeBox.MinPoint.x)
    ay = 10 * (bauteil.RangeBox.MaxPoint.y - bauteil.RangeBox.MinPoint.y)
    aZ = 10 * (bauteil.RangeBox.MaxPoint.z - bauteil.RangeBox.MinPoint.z)

    If (ax < x) And (ay < y) And (aZ < z) Then
        BauteilUnterdrücken = True
    Else
        BauteilUnterdrücken = False
    End If

End Function

Sub ErzeugeDetailgenauigkeit(baugruppe As AssemblyComponentDefinition, bez As String)
    
    Dim DGVorhanden As Boolean
    DGVorhanden = False
    ' Create a new level of detail representation.
    ' The new representation is automatically activated.
    Dim oLODRep As LevelOfDetailRepresentation
    Dim oRM As RepresentationsManager
    Set oRM = baugruppe.RepresentationsManager
    Dim oLOD As LevelOfDetailRepresentation
    For Each oLOD In oRM.LevelOfDetailRepresentations
        If oLOD.name = bez Then
            DGVorhanden = True
        Else
            DGVorhanden = False
        End If
    Next
    If DGVorhanden = False Then
        Set oLOD = oRM.LevelOfDetailRepresentations.Add(bez)
        oRM.LevelOfDetailRepresentations.Item(bez).Activate (True)
    Else
        'Set oLOD = oRM.LevelOfDetailRepresentations.Item(bez)
        oRM.LevelOfDetailRepresentations.Item(bez).Activate (True)
    End If
    
End Sub

I hope somebody have a solution

Best regards

Harald

[HermJan.Otterman]

did you know about the selection filters in an Assembly?

in an Assy, Press shift+rightmouse

- first: select "Part Priority"

- Second: press again shift+rightmous, then select "component size"

after selecting all the small parts, you can do something with them...