Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.
Anonymous
in reply to: Anonymous

Not perfect, but I've been working on similar for a while now.

 

This is the best I've got.  You have to name your solids appropriately and tailor the options to your liking but this may give you a start.  It goes through a part, finds each solid and cuts out or intersects the interference solid based on which routine you run.  This is all done after you derive a new solid into your part.  It won't help automate deriving the part, just combining afterward.

 

Option Explicit
Dim oSurfBody As SurfaceBody
Dim oCompDef As ComponentDefinition
Dim oPartCompDef As PartComponentDefinition
Dim oPartDoc As PartDocument
Public Sub DeriveCaution()
    On Error GoTo error_checking
    Dim lngErr As Long
    Dim i As Long
    Dim oSurfBodies As SurfaceBodies
    
    Set oPartDoc = ThisApplication.ActiveDocument
    Set oPartCompDef = oPartDoc.ComponentDefinition
    
    Dim oSBInt As SurfaceBody
    Dim oSBCaut As SurfaceBody
    Dim oSBMain As SurfaceBody
    Set oSurfBodies = oPartCompDef.SurfaceBodies

    For Each oSurfBody In oPartCompDef.SurfaceBodies
        If oSurfBody.Name = "Int" Then
            Set oSBInt = oSurfBody
        ElseIf oSurfBody.Name = "Caut" Then
            Set oSBCaut = oSurfBody
        ElseIf oSurfBody.Name = "Main" Then
            Set oSBMain = oSurfBody
        End If
    Next oSurfBody
    Dim test As Long
    oSBInt.Visible = False
    oSBCaut.Visible = False
    oSBMain.Visible = False
    
    For i = 1 To oPartCompDef.SurfaceBodies.Count
        Set oSurfBodies = oPartCompDef.SurfaceBodies
    
        For Each oSurfBody In oPartCompDef.SurfaceBodies
            If oSurfBody.Name = "Int" Then
                Set oSBInt = oSurfBody
             ElseIf oSurfBody.Name = "Caut" Then
                Set oSBCaut = oSurfBody
            ElseIf oSurfBody.Name = "Main" Then
                Set oSBMain = oSurfBody
            End If
        Next oSurfBody
        Set oSurfBody = oPartCompDef.SurfaceBodies.Item(i)
        Call IntCombine(oSurfBody, oSBCaut)
    Next i
    
error_checking:
lngErr = Err.Number

End Sub
Public Sub DeriveInterference()
    On Error GoTo error_checking
    Dim lngErr As Long
    Dim i As Long
    Dim oSurfBodies As SurfaceBodies
    
    Set oPartDoc = ThisApplication.ActiveDocument
    Set oPartCompDef = oPartDoc.ComponentDefinition
    
    Dim oSBInt As SurfaceBody
    Dim oSBCaut As SurfaceBody
    Dim oSBMain As SurfaceBody
    Set oSurfBodies = oPartCompDef.SurfaceBodies

    For Each oSurfBody In oPartCompDef.SurfaceBodies
        If oSurfBody.Name = "INT" Then
            Set oSBInt = oSurfBody
        ElseIf oSurfBody.Name = "CAUT" Then
            Set oSBCaut = oSurfBody
        ElseIf oSurfBody.Name = "Main" Then
            Set oSBMain = oSurfBody
        End If
    Next oSurfBody
    Dim test As Long
    oSBInt.Visible = False
    oSBCaut.Visible = False
    oSBMain.Visible = False
    
    For i = 1 To oPartCompDef.SurfaceBodies.Count

        Set oSurfBodies = oPartCompDef.SurfaceBodies
    
        For Each oSurfBody In oPartCompDef.SurfaceBodies
            If oSurfBody.Name = "INT" Then
                Set oSBInt = oSurfBody
             ElseIf oSurfBody.Name = "CAUT" Then
                Set oSBCaut = oSurfBody
            ElseIf oSurfBody.Name = "Main" Then
                Set oSBMain = oSurfBody
            End If
        Next oSurfBody
        Set oSurfBody = oPartCompDef.SurfaceBodies.Item(i)
        Call IntCombine(oSurfBody, oSBInt)
    Next i
    
error_checking:
lngErr = Err.Number

End Sub
Public Sub DeriveMain()

    On Error GoTo error_checking
    Dim lngErr As Long
    Dim i As Long
    Dim oSurfBodies As SurfaceBodies
    
    Set oPartDoc = ThisApplication.ActiveDocument
    Set oPartCompDef = oPartDoc.ComponentDefinition
    
    Dim oSBInt As SurfaceBody
    Dim oSBCaut As SurfaceBody
    Dim oSBMain As SurfaceBody
    Set oSurfBodies = oPartCompDef.SurfaceBodies

    For Each oSurfBody In oPartCompDef.SurfaceBodies
        If oSurfBody.Name = "INT" Then
            Set oSBInt = oSurfBody
        ElseIf oSurfBody.Name = "CAUT" Then
            Set oSBCaut = oSurfBody
        ElseIf oSurfBody.Name = "Main" Then
            Set oSBMain = oSurfBody
        End If
    Next oSurfBody

    oSBInt.Visible = False
    oSBCaut.Visible = False
    oSBMain.Visible = False
    
    For i = 1 To oPartCompDef.SurfaceBodies.Count
        Set oSurfBody = oPartCompDef.SurfaceBodies.Item(i)
        Call CutCombine(oSurfBody, oSBInt, oSBCaut)
    Next i
    
error_checking:
lngErr = Err.Number
MsgBox Now


End Sub

Public Sub CutCombine(sbBase As SurfaceBody, ocRemove1 As SurfaceBody, ocRemove2 As SurfaceBody)
    

    Dim oCombFeat As CombineFeature
    Dim oCombFeats As CombineFeatures
    Dim ocRemove As ObjectCollection
    Dim oTO As TransientObjects
    
    Set oTO = ThisApplication.TransientObjects
    Set ocRemove = oTO.CreateObjectCollection
    Call ocRemove.Add(ocRemove1)
    Call ocRemove.Add(ocRemove2)
   
    If Not (sbBase.Name = "INT") And Not (sbBase.Name = "CAUT") _
        And Not (sbBase.Name = "Main") Then
        sbBase.Visible = True
        Set oCombFeats = oPartCompDef.Features.CombineFeatures
        
        If Not (CombineFeatureExists(sbBase)) Then
            Set oCombFeat = oCombFeats.Add _
                (sbBase, ocRemove, kCutOperation, True)
        End If
    End If
End Sub
Public Sub IntCombine(sbBase As SurfaceBody, sbIntersect As SurfaceBody)

    Dim oCombFeat As CombineFeature
    Dim oCombFeats As CombineFeatures
    Dim ocRemove As ObjectCollection
    Dim oTO As TransientObjects
    
    Set oTO = ThisApplication.TransientObjects
    Set ocRemove = oTO.CreateObjectCollection
    Call ocRemove.Add(sbIntersect)
    
    If Not (sbBase.Name = "INT") And Not (sbBase.Name = "CAUT") _
        And Not (sbBase.Name = "Main") Then
        sbBase.Visible = True
        Set oCombFeats = oPartCompDef.Features.CombineFeatures

        If Not (CombineFeatureExists(sbBase)) Then
            Set oCombFeat = oCombFeats.Add _
              (sbBase, ocRemove, kIntersectOperation, True)
        End If
    End If
End Sub
Private Function CombineFeatureExists(sbCombFeatSB As SurfaceBody) As Boolean
    Dim cfExists As Boolean
    Dim j As Long
    Dim oCombFeats As CombineFeatures
    
    Set oCombFeats = oPartCompDef.Features.CombineFeatures
    
    cfExists = False
    
    For j = 1 To oCombFeats.Count
        If (oCombFeats.Item(j).SurfaceBodies.Item(1).Name = sbCombFeatSB.Name) Then
            cfExists = True
        End If
    Next j
    
    CombineFeatureExists = cfExists

End Function