# Macro slices body by sections using SOLIDWORKS API

This example demonstrates how to slice the selected body and find the section properties of the resulting section slices using SOLIDWORKS API.

• Specify the number of required slices in the SLICES_COUNT constant
```Const SLICES_COUNT As Integer = 100
```
• Select solid body in Part document
• As the result:
• Body is sliced in Y direction
• Area of each slice is output to the immediate window in VBA editor
• Previews of each slice is displayed in the graphics area
• Continue the macro to hide the preview

## Algorithm

### Identifying the starting point and the maximum length of the body

• Find 2 extreme points in positive and negative direction of the direction vector (Y vector in this example)
• Project those points onto the direction vector line (vector can be fixed at any point, in this example it is fixed at 0, 0, 0).
• Once projected calculate the distance between points - this will be equal to the maximum length of the body
• First extreme point is a starting point

### Identifying the maximum radius of the body

It is only required to find big enough radius to cover the body. This radius will be used to create a planar body for intersection purposes. In this example the maximum radius is equal to the diagonal of the bounding box which will ensure the planar section will cover the input body

### Calculate sections

• Calculate the step of section
• For each section move the starting point by the step. Sections at end points should be skipped as it won't produce any intersection results
• At each step create a temp section plane (disc) and intersect it with the solid body
• Result of the intersection is the sheet body (or bodies) which is a section slice at this position
• Store the pointer to the section in the collection
• All the properties can be accessed from the resulting body (e.g. surface area)

### Preview the results

• Display each of the resulting bodies as a preview
• Stop the execution of the macro to validate the result
• It might be required to hide or change the transparency of the original body to see the sections displayed
• Continue macro execution. This will clear the preview

```Const SLICES_COUNT As Integer = 100

Dim swApp As SldWorks.SldWorks

Sub main()

Set swApp = Application.SldWorks

Dim swModel As SldWorks.ModelDoc2

Set swModel = swApp.ActiveDoc

If Not swModel Is Nothing Then

Dim swBody As SldWorks.Body2
Set swBody = swModel.SelectionManager.GetSelectedObject6(1, -1)

If Not swBody Is Nothing Then

Dim startTime As Double
startTime = Timer

Dim swSliceBodies As Collection
Set swSliceBodies = New Collection

Dim i As Integer

Dim dNorm(2) As Double
Dim dRef(2) As Double

dNorm(0) = 0: dNorm(1) = 1: dNorm(2) = 0
dRef(0) = 1: dRef(1) = 0: dRef(2) = 0

Dim vStartPt As Variant
Dim length As Double
vStartPt = GetStartPoint(swBody, dNorm, length)

Dim step As Double
step = length / (SLICES_COUNT + 1)

For i = 1 To (SLICES_COUNT + 1) - 1

Dim swCutPlane As SldWorks.Body2

Dim vRoot As Variant
vRoot = MovePoint(vStartPt, dNorm, step * i)

Set swCutPlane = CreatePlanarBody(vRoot, dNorm, dRef, maxRadius)

Dim swTempBody As SldWorks.Body2
Set swTempBody = swBody.Copy

Dim bodyErr As Long
Dim vRes As Variant
vRes = swCutPlane.Operations2(swBodyOperationType_e.SWBODYINTERSECT, swTempBody, bodyErr)

Dim j As Integer

If Not IsEmpty(vRes) Then
For j = 0 To UBound(vRes)
Dim swResBody As SldWorks.Body2
Set swResBody = vRes(j)
Debug.Print "Area: " & swResBody.GetMassProperties(0)(4)
Next
Else
err.Raise vbError, , "Intersection failed"
End If

Next

Debug.Print "Time: " & Round(Timer - startTime, 2)

For i = 1 To swSliceBodies.Count
swSliceBodies(i).Display3 swModel, RGB(255, 255, 0), swTempBodySelectOptions_e.swTempBodySelectOptionNone
Next

Stop

For i = swSliceBodies.Count To 1 Step -1
swSliceBodies.Remove i
Next

Else
End If

Else
End If

End Sub

Function GetMaxRadius(body As SldWorks.Body2) As Double

Dim vBox As Variant
vBox = body.GetBodyBox()

GetMaxRadius = Sqrt((vBox(3) - vBox(0)) ^ 2 + (vBox(4) - vBox(1)) ^ 2 + (vBox(5) - vBox(2)) ^ 2)

End Function

Function GetStartPoint(body As SldWorks.Body2, vDir As Variant, ByRef length As Double) As Variant

Dim x As Double
Dim y As Double
Dim z As Double

body.GetExtremePoint CDbl(-vDir(0)), CDbl(-vDir(1)), CDbl(-vDir(2)), x, y, z

Dim dPt(2) As Double
dPt(0) = x: dPt(1) = y: dPt(2) = z

GetStartPoint = dPt

body.GetExtremePoint CDbl(vDir(0)), CDbl(vDir(1)), CDbl(vDir(2)), x, y, z

dPt(0) = x: dPt(1) = y: dPt(2) = z

Dim dVecPt(2) As Double

Dim vPt1 As Variant
Dim vPt2 As Variant

vPt1 = ProjectPointOnVector(GetStartPoint, vDir, dVecPt)
vPt2 = ProjectPointOnVector(dPt, vDir, dVecPt)

length = Sqrt((vPt1(0) - vPt2(0)) ^ 2 + (vPt1(1) - vPt2(1)) ^ 2 + (vPt1(2) - vPt2(2)) ^ 2)

End Function

Function ProjectPointOnVector(vPt As Variant, vVec As Variant, vPtOnVec As Variant) As Variant

Dim swMathUtils As SldWorks.MathUtility
Set swMathUtils = swApp.GetMathUtility

Dim swPt As SldWorks.MathPoint
Dim swVec As SldWorks.MathVector
Dim swPtOnVec As SldWorks.MathPoint

Set swPt = swMathUtils.CreatePoint(vPt)
Set swVec = swMathUtils.CreateVector(vVec)
Set swPtOnVec = swMathUtils.CreatePoint(vPtOnVec)

Dim swVec2 As SldWorks.MathVector
Set swVec2 = swPtOnVec.Subtract(swPt)

Dim magn As Double
Dim prod As Double
Dim dist As Double

prod = swVec.Dot(swVec2)
magn = swVec.GetLength() ^ 2
dist = prod / magn

Dim swDestPt As SldWorks.MathPoint

ProjectPointOnVector = swDestPt.ArrayData

End Function

Function CreatePlanarBody(vRoot As Variant, vNorm As Variant, vRef As Variant, radius As Double) As SldWorks.Body2

Dim swModeler As SldWorks.Modeler

Set swModeler = swApp.GetModeler

Dim swSurf As SldWorks.Surface

Set swSurf = swModeler.CreatePlanarSurface2(vRoot, vNorm, vRef)

Dim swTrimCurve(0) As SldWorks.Curve

Dim vArcPt As Variant

Set swTrimCurve(0) = swModeler.CreateArc(vRoot, vNorm, radius, vArcPt, vArcPt)

Set CreatePlanarBody = swSurf.CreateTrimmedSheet4(swTrimCurve, True)

End Function

Function MovePoint(vPt As Variant, vDir As Variant, dist As Double) As Variant

Dim swMathUtils As SldWorks.MathUtility

Set swMathUtils = swApp.GetMathUtility

Dim swPt As SldWorks.MathPoint
Dim swDir As SldWorks.MathVector

Set swPt = swMathUtils.CreatePoint(vPt)
Set swDir = swMathUtils.CreateVector(vDir)

Set swDir = swDir.Normalise()
Set swDir = swDir.Scale(dist)