Pattern input bodies

[Fleuve]

Hello,

     I Try to do 2 thing with pattern. The first one, it's get result of a pattern (Mirror, rectangular or circular) and change Occurrence name after the operation.... DONE! (With SurfaceBodies)

The second thing i try to reach the input bodies, to add or remove bodies from pattern... but HOW?

  Dim oDocument As PartDocument
    Set oDocument = ThisApplication.ActiveDocument
    
    ' ****** Rename Rectangular Pattern ***********
    Dim oRectPatFeature As RectangularPatternFeatures
    Set oRectPatFeature = oDocument.ComponentDefinition.Features.RectangularPatternFeatures
    
    Dim oRectPatt As RectangularPatternFeature
    Set oRectPatt = oRectPatFeature.Item(1)

    Debug.Print oRectPatt.Name
    Debug.Print oRectPatt.SurfaceBodies.Count
    For i = 1 To oRectPatt.SurfaceBodies.Count
        Debug.Print oRectPatt.SurfaceBodies.Item(i).Name
        'oRectPatt.SurfaceBodies.Item(i).Name = "Darton-" & i + 2
    Next i
    

Thanks!

[WCrihfield]

Hi @Fleuve.  This can be a pretty tricky thing accomplish by code.  Since you seem to have already found the RectangularPatternFeature , if you are trying to access the objects used as input (original objects to be patterned), you will need to get the pattern's 'Definition', which is a RectangularPatternFeatureDefinition.  Within that definition is a property called 'ParentFeatures', which returns an ObjectCollection.  That collection should contain those original objects.  I don't recall if you can simply take objects out of that collection using the methods defined under the ObjectCollection, or if you have to create a new ObjectCollection then set the new collection as its value to replace the original.  One or the other seems like it should work since the ParentFeatures property is Read/Write.

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

If you want and have time, I would appreciate your Vote(s) for My IDEAS 💡or you can Explore My CONTRIBUTIONS

[Fleuve]

Thanks for the reply... For the moment I agree and I understand where you try to guide me. I look carefully inside the VBA Object Explorer (F2) and I made some test. But unfortunately I still receive error.

    Dim oDocument As PartDocument
    Set oDocument = ThisApplication.ActiveDocument
    
    ' ****** Rename Rectangular Pattern ***********
    Dim oRectPatFeature As RectangularPatternFeatures
    Set oRectPatFeature = oDocument.ComponentDefinition.Features.RectangularPatternFeatures
    
    Dim oRectPatt As RectangularPatternFeature
    Set oRectPatt = oRectPatFeature.Item(1)

    Debug.Print oRectPatt.Name
    Debug.Print oRectPatt.SurfaceBodies.Count
    For i = 1 To oRectPatt.SurfaceBodies.Count
        Debug.Print oRectPatt.SurfaceBodies.Item(i).Name
        'oRectPatt.SurfaceBodies.Item(i).Name = "Darton-" & i + 2
    Next i
    
' ************** NEW PART *************************************************
    Dim oRectDef As RectangularPatternFeatureDefinition
    Set oRectDef = oRectPatt.Definition
    
    Dim Coll As ObjectCollection
    'Set Coll = oRectDef.AffectedBodies          'ERROR -2147467259 (800004005)
    'Set Coll = oRectDef.AffectedOccurrences     'ERROR 445
    'Set Coll = oRectDef.ParentFeatures          'WORK but Count = 0

[Fleuve]

I made some test.. Parent feature  work with feature pattern but not with bodies pattern. Does I have corrupt dependency like Framework or VS Redist? I'm using 2022 with no update. I send a compact version of the project. All inside VBA. But for the moment, I crash on bodies pattern.

Public Sub Pattern(ID As Integer)
    Dim oDocument As PartDocument
    Set oDocument = ThisApplication.ActiveDocument
    
    Dim oRectPatFeature As RectangularPatternFeatures
    Set oRectPatFeature = oDocument.ComponentDefinition.Features.RectangularPatternFeatures
    
    Dim oRectPatt As RectangularPatternFeature
    Set oRectPatt = oRectPatFeature.Item(ID)

    Debug.Print "Rectangular Pattern Name : " & oRectPatt.Name
    Debug.Print "Output Bodies Count : " & oRectPatt.SurfaceBodies.Count
    For i = 1 To oRectPatt.SurfaceBodies.Count
        Debug.Print "Output Bodies : " & oRectPatt.SurfaceBodies.Item(i).Name
    Next i
    
    ' ************** NEW PART *************************************************
    Dim oRectDef As RectangularPatternFeatureDefinition
    Set oRectDef = oRectPatt.Definition
    
    Dim ParentFeature As ObjectCollection                ' ***** PARENT FEATURE ***********
    Set ParentFeature = oRectDef.ParentFeatures          'WORK but Count = 0
    
    Debug.Print "Pattern of Body : " & oRectDef.PatternOfBody
    Debug.Print "Parent Features Collection Count : " & ParentFeature.Count
    
    If (ParentFeature.Count > 0) Then
        For i = 1 To ParentFeature.Count
            Debug.Print "Feature Input : " & ParentFeature.Item(i).Name
        Next i
    End If
    
    If (oRectDef.PatternOfBody = False) Then                  'TRUE GIVE ERROR
        Dim AffectedBodies As ObjectCollection
        Set AffectedBodies = oRectDef.AffectedBodies          'ERROR -2147467259 (800004005)
        Debug.Print "Affected Bodies Count : " & AffectedBodies.Count
        For i = 1 To AffectedBodies.Count
            Debug.Print "Affected Body : " & AffectedBodies.Item(i).Name
        Next i
    End If
   
    Debug.Print "---------------------"
End Sub

Public Sub TestPat()
    Pattern (1)
    Pattern (2)
    Pattern (3)
End Sub

the result

Rectangular Pattern Name : Réseau rectangulaire1
Output Bodies Count : 1
Output Bodies : Solide1
Pattern of Body : False
Parent Features Collection Count : 1
Feature Input : Extrusion1
Affected Bodies Count : 1
Affected Body : Solide1
---------------------
Rectangular Pattern Name : Réseau rectangulaire2
Output Bodies Count : 1
Output Bodies : Solide1
Pattern of Body : True
Parent Features Collection Count : 0
---------------------
Rectangular Pattern Name : Réseau rectangulaire3
Output Bodies Count : 1
Output Bodies : Solide2
Pattern of Body : True
Parent Features Collection Count : 0
---------------------

You can also check TestPatten.ipt

Thanks!