Macro slices body by sections using SOLIDWORKS API


Section slices of the body
Section slices of the body

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


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 maxRadius As Double
            maxRadius = GetMaxRadius(swBody)
            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)
                        swSliceBodies.Add swResBody
                    err.Raise vbError, , "Intersection failed"
                End If
            Debug.Print "Time: " & Round(Timer - startTime, 2)
            For i = 1 To swSliceBodies.Count
                swSliceBodies(i).Display3 swModel, RGB(255, 255, 0), swTempBodySelectOptions_e.swTempBodySelectOptionNone
            For i = swSliceBodies.Count To 1 Step -1
                swSliceBodies.Remove i
            MsgBox "Please select body"
        End If
        MsgBox "Please open model"
    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
    Set swDestPt = swPtOnVec.AddVector(swVec.Scale(dist))
    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
    vArcPt = MovePoint(vRoot, vRef, radius)
    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)
    Set swPt = swPt.AddVector(swDir)
    MovePoint = swPt.ArrayData
End Function

Product of Xarial Product of Xarial