Updated defeature part macro

Author: Artem Taturevych

solidworks-api/document/features-manager/defeature-part/Macro.vba

@@ -4,88 +4,129 @@ Sub main()
 
     Set swApp = Application.SldWorks
 
+try_:
+    
+    On Error GoTo catch_
+    
     Dim swPart As SldWorks.PartDoc
 
     Set swPart = swApp.ActiveDoc
 
     If Not swPart Is Nothing Then
 
-        Dim vBodies As Variant
-        vBodies = GetBodyCopies(swPart)
+        Dim vUserFeats As Variant
+        vUserFeats = GetAllTopLevelUserFeatures(swPart)
 
-        DeleteAllUserFeatures swPart
-        
-        CreateFeaturesForBodies swPart, vBodies
+        If Not IsEmpty(vUserFeats) Then
+            CreateFeaturesForBodies swPart
+            DeleteFeatures swPart, vUserFeats
+        Else
+            Err.Raise vbError, "", "No features in the model"
+        End If
 
     Else
         MsgBox "Please open part document"
     End If
 
+    GoTo finally_
+    
+catch_:
+    MsgBox Err.Description, vbCritical
+finally_:
+    
 End Sub
 
-Function GetBodyCopies(part As SldWorks.PartDoc) As Variant
+Sub CreateFeaturesForBodies(part As SldWorks.PartDoc)
 
     Dim vBodies As Variant
-        
-    vBodies = part.GetBodies2(swBodyType_e.swAllBodies, True)
-    Dim i As Integer
 
-    For i = 0 To UBound(vBodies)
+    vBodies = part.GetBodies2(swBodyType_e.swAllBodies, False)
+    
+    If Not IsEmpty(vBodies) Then
+                
+        Dim i As Integer
 
-        Dim swBody As SldWorks.Body2
-        Set swBody = vBodies(i)
-        Set swBody = swBody.Copy()
-        Set vBodies(i) = swBody
+        For i = 0 To UBound(vBodies)
+            
+            Dim swBody As SldWorks.Body2
+            Set swBody = vBodies(i)
+            Set swBodyCopy = swBody.Copy()
+                        
+            Dim swFeat As SldWorks.Feature
 
-    Next
-    
-    GetBodyCopies = vBodies
-    
-End Function
-
-Sub CreateFeaturesForBodies(part As SldWorks.PartDoc, vBodies As Variant)
-    
-    Dim i As Integer
+            Set swFeat = part.CreateFeatureFromBody3(swBodyCopy, False, swCreateFeatureBodyOpts_e.swCreateFeatureBodySimplify)
+            
+            If Not swFeat Is Nothing Then
+                
+                Dim swFace As SldWorks.Face2
+                Set swFace = swFeat.GetFaces()(0)
+                
+                Dim swReplacedBody As SldWorks.Body2
+                Set swReplacedBody = swFace.GetBody
+                
+                swReplacedBody.HideBody False = swBody.Visible
+                
+            Else
+                Err.Raise vbError, "", "Failed to create feature for a body " & swBody.Name
+            End If
+                        
+        Next
 
-    For i = 0 To UBound(vBodies)
-        Dim swBody As SldWorks.Body2
-        Set swBody = vBodies(i)
-        part.CreateFeatureFromBody3 swBody, False, swCreateFeatureBodyOpts_e.swCreateFeatureBodySimplify
-    Next
+    Else
+        
+        Err.Raise vbError, "", "No bodies found"
+        
+    End If
 
 End Sub
 
-Sub DeleteAllUserFeatures(model As SldWorks.ModelDoc2)
+Sub DeleteFeatures(model As SldWorks.ModelDoc2, feats As Variant)
 
-    SelectAllTopLevelUserFeatures model
-            
-    model.Extension.DeleteSelection2 swDeleteSelectionOptions_e.swDelete_Children + swDeleteSelectionOptions_e.swDelete_Absorbed
+    If model.Extension.MultiSelect2(feats, False, Nothing) = UBound(feats) + 1 Then
+        model.Extension.DeleteSelection2 swDeleteSelectionOptions_e.swDelete_Children + swDeleteSelectionOptions_e.swDelete_Absorbed
+    Else
+        Err.Raise vbError, "", "Failed to select user features"
+    End If
 
 End Sub
 
-Sub SelectAllTopLevelUserFeatures(model As SldWorks.ModelDoc2)
+Function GetAllTopLevelUserFeatures(model As SldWorks.ModelDoc2) As Variant
 
-    model.ClearSelection2 True
+    Dim swUserFeats() As SldWorks.Feature
 
     Dim swFeat As SldWorks.Feature
 
     Set swFeat = model.FirstFeature
 
-    Dim selectFeat As Boolean
-    selectFeat = False
+    Dim isUserFeat As Boolean
+    isUserFeat = False
 
     While Not swFeat Is Nothing
 
-        If selectFeat Then
-            swFeat.Select2 True, -1
+        If isUserFeat Then
+
+            If (Not swUserFeats) = -1 Then
+                ReDim swUserFeats(0)
+            Else
+                ReDim Preserve swUserFeats(UBound(swUserFeats) + 1)
+            End If
+            
+            Set swUserFeats(UBound(swUserFeats)) = swFeat
+        
         Else
             If swFeat.GetTypeName2() = "OriginProfileFeature" Then
-                selectFeat = True
+                isUserFeat = True
             End If
         End If
 
         Set swFeat = swFeat.GetNextFeature
 
     Wend
 
-End Sub
+    If (Not swUserFeats) = -1 Then
+        GetAllTopLevelUserFeatures = Empty
+    Else
+        GetAllTopLevelUserFeatures = swUserFeats
+    End If
+    
+End Function

solidworks-api/document/features-manager/defeature-part/index.md

@@ -5,9 +5,9 @@ description: Macro to convert all features in part to dumb solids (defeature par
 image: part-feature-tree-defeatured.png
 labels: [defeature,parasolid]
 ---
-This macro emulates the functionality of [Defeature for Part](https://help.solidworks.com/2018/english/solidworks/sldworks/c_defeature_for_parts.htm) but not using it directly.
+This VBA macro defeatures the active SOLIDWORKS part. Unlike the [Defeature for Part](https://help.solidworks.com/2018/english/solidworks/sldworks/c_defeature_for_parts.htm) functionality, this macro preserves the original geometry and does not simplify it.
 
-Macro copies all visible solid and surface bodies, deletes all user features and imports the copied bodies using SOLIDWORKS API.
+Macro copies all solid and surface bodies, deletes all user features and imports the copied bodies using SOLIDWORKS API. Macro will preserve the hidden flag from the original bodies.
 
 **Before:**